# HG changeset patch # User cvs # Date 1186989236 -7200 # Node ID 0d2f883870bc005fe0117d0dd3a5ac8eb0dbf79e # Parent 498bf5da1c902a828fd57d4d495cd1b4db7751b9 Import from CVS: tag r20-1b1 diff -r 498bf5da1c90 -r 0d2f883870bc CHANGES-beta --- a/CHANGES-beta Mon Aug 13 09:12:43 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 09:13:56 2007 +0200 @@ -1,1663 +1,34 @@ -*- indented-text -*- -to 20.0 final --- Replicating extents are history --- Miscellaneous bug fixes - -to 20.0 final --- iso-acc.el updated courtesy of Alexandre Oliva --- Miscellaneous bug fixes - -to 20.0 beta93 --- tm-7.101 --- w3-3.0.51 --- Miscellaneous bug fixes - -to 20.0 beta92 --- Miscellaneous bug fixes - -to 20.0 beta91 --- func-menu.el-2.45 --- ediff-2.64 --- viper-2.92 --- w3-3.0.50 --- html 3.2 final dtd added. --- Miscellaneous bug fixes --- ps-print.el-3.05 Courtesy of Jacques Duthen Prestataire - -to 20.0 beta90 --- ediff-2.64 --- viper-2.92 --- bench.el-1.2 --- Degenerate extent insertion speedup courtesy of David Moore --- decipher.el (from Emacs 19.34) --- w3-3.0.43 --- Miscellaneous bug fixes - -to 20.0 beta34 --- backup-dir 2.0 courtesy of Greg Klanderman --- lazy-lock-1.15 --- tm-7.100.3 --- Various patches courtesy of Joel Peterson --- viper-2.91 --- ediff-2.63 --- psgml-1.01 --- Miscellaneous bug fixes - -to 20.0 beta33 --- 20k of new zippy quotes from mly --- By popular demand, `font-menu-this-frame-only-p' now defaults to nil. --- tm-7.100.2 --- Neal Becker's Rosetta Man patch reinstalled --- VM 5.97 --- Minimize displayed help windows to avoid wasted screen space --- Miscellaneous bug fixes --- Java fontlocking update from Bob Weiner --- pcl-cvs update from Neal Becker - -to 20.0 beta32 --- InfoDock man.el --- Fix long-standing race condition in timeout handling (courtesy of David - Moore). --- next-line-add-newlines now defaults to nil --- tm-7.97 --- charset renames for Mule 2.4 and TM compatibility. --- ANSIfication of the code base is mostly completed. --- Random bug fixes. --- Default JPEG image loading is now old tempfile code, but should work again. --- Keysyms now use dashes instead of underscores for compatibility. --- Miscellaneous bug fixes courtesy of Christoph Wedler --- mic-paren.el courtesy of Mikael Sjdin --- lpr.el/ps-print.el - Allow dynamic expansion of - lpr-switches/ps-lpr-switches. --- Lisp Bug fixes --- Install info files compressed (courtesy of Joseph J Nuspl) --- Default locking for Linux is now .lock locking - -to 20.0 beta31 - --- EDT/TPU modes synched from GNU Emacs, should actually work for the first - first time. --- Lots of files synched with GNU Emacs 19.34. --- Apropos mode enhancements. --- locate-library is now silent when called non-interactively. --- Non aggressive keyboard focus throwing is supported. --- Various enhancements from Lars Magne Ingebrigtsen. --- smtpmail.el added from GNU Emacs 19.34. --- man.el & man-xref.el added from GNU Emacs 19.35. --- crisp/brief emulation courtesy of Gary D. Foster. --- id-select.el courtesy of Bob Weiner. --- pretty-print.el courtesy of Guido Bosch --- vhdl-mode.el Version 2.73 courtesy of Rod Whitby. - -to 20.0 beta30 - --- Syntax entry specification "e" has been removed. --- updated xemacs.1 man page for new argument list handling. --- updated internals document to reflect new DEFUN macro. - --- (load-average) works on Solaris. Thanks to Hrvoje Niksic. - --- Command line processing now order independent --- Command line like: xemacs file -eval '(munge-file)' - now works. --- Now uses XmIm* functions for XIM input when available --- Major cleanup of configure.in - preparation for Autoconf 2 upgrade. --- `man' directory reorganized. --- The `dvi' and `info' targets now work in the man directory. --- texinfo 3.7 no longer comes with XEmacs. User must supply own - makeinfo or TeX to rebuild info files or to print hardcopy. --- execvp has been encapsulated. The command line of executed - commands now is converted using pathname-coding-system before the - command is run. --- Use flag -fno-gnu-linker if using gcc with dynodump (i.e. on - solaris) --- m4-mode 1.8 --- etags.c 11.78 --- ilisp 5.8 --- cperl-mode 1.28 --- cc-mode 4.322 --- elp 2.37 --- python-mode 2.83 --- load-warn-when-source-newer now defaults to t --- purespace messages from loadup.el now much more reasonable. --- Changed lispref documentation to refer to frame properties, not parameters. --- Synched up files.el: file-relative-name (Steven Baur's patch) --- Fix: shell history works if commands contain non-ASCII characters. --- Fix: shell commands can contain non-ASCII characters. --- Fix: dired on Non-ASCII filename now works --- Fix: repeat-complex-command fails when repeating M-x emacs-version --- tm 7.94 integrated - default in XEmacs/Mule - - Japanese newsgroups now readable without .emacs modifications. --- Johan Vroman's iso-acc.el ported to XEmacs by Alexandre Oliva --- Made startup option processing more sensible - - Eliminate most order dependencies - - more compatible with FSF - - Some additional flags (-V equivalent to -version, -flags == -help) --- Michael Sperber's psgml-html patch --- Makefile rule to create TAGS file now properly creates tags for - DEFVAR_* macros. --- DEFUN macro has major facelift: - - No need to specify both Ffoo and Sfoo - - Arglist is more Lispy - no more K&R style function definitions. - - DOC file creation modified to deal with new style DEFUN. --- X selection code Re-Mule-ized - Should interoperate with other X clients. --- beginnings of TM integration --- When regexp is [^CHARACTERS] and first character of string is - non-ASCII character, XEmacs crashes. Fixed for real this time? --- fixed redundant, buggy calls to (message (format ...)) - In particular (occur "%") now works. --- support for creating .i files (useful for debugging) in src/ --- make src/Makefile.in.in makefile-mode-friendly --- define and use macros XSTRING_LENGTH, XSTRING_DATA, with obvious - meanings. --- eliminate calls to x_smash_bastardly_shell_position. The Xt shell - widget core fields are no longer overwritten with values that Xt - would not have put there itself. --- support for CDE drag and drop of data, not just files. --- XIM patch from Jareth Hein (but XIM still doesn't work for him) --- COMPREHENSIBLE puresize information when --with-debug specified --- if get_eof_char is called without a pty, should not call tcgetattr() --- Fix crash if delete-frame-hook selects the about-to-be-deleted - frame, by calling delete-frame-hook at the beginning of - delete-frame code. --- Fix run-time warnings detected by Sun WorkShop dbx rtc tool. --- possible fix for assertion failure in open-network-stream --- server-make-window-visible more portable --- locate-library now accpts both symbols and strings. --- buffer names in the buffer menus are no longer translated - they - are put into the `suffix' part of the label. - -to 20.0 beta29 - --- fast-lock.el 3.10.01 --- ksh-mode.el 2.9 --- mode-motion+.el 3.16 --- psgml-1a12 --- executable.el, imenu.el, sh-script.el and uniquify.el now included --- rfc1521 patches to VM from Jamie --- OffiX support added --- lots of 19.34 syncing, most by Steven Baur --- NetBSD on sparc platform fixes --- additional featurep checks on 'scrollbar and 'menubar --- configure changes to allow sunos4shr args to be picked up correctly - -to 20.0 beta28 - --- gnus 5.2.40 --- etc 0.22 --- w3 3.0.12 --- reporter 3.3 --- psgml 1a11 --- cc-mode 4.315 --- hm--html-menus 5.0 --- other assorted fixes and changes --- python-mode 2.73 --- minor corrections to sample.emacs --- added localization hook for lisp/locale/LANG/locale-start.el --- face-complain-about-font now offers an Action Plan after whining. --- Editing of filenames encoded in pathname-coding-system now works. --- Characters in current locale displayed properly in frame title and - icon name. --- Characters in current locale displayed properly in menubar. --- Resize frame, then (set-frame-properties (selected-frame) '(left 100)) - would always move to (x=100, y=0) --- {de,en}code-coding-string rewritten - should work now. --- delete-frame-hook docstring warns not to select frame-to-be-deleted --- When regexp is [^CHARASTERS] and first character of string is - non-ASCII character, XEmacs crashes. - Oops ix! Fix undone. Problem still there. --- (XIM) ^G and friends no longer self-inserting --- (Mule) byte-compilation problems fixed --- describe-last-error fixed --- frame 'minibuffer property correctly computed. --- implementation of (set-charset-registry) --- (charset-dimension) now works --- Setting language environment to japanese does - (set-charset-registry 'ascii "JISX0201") --- Fixed encode-coding-string, decode-coding-string --- face-complain-about-font now gives more useful warning. - - -to 20.0 beta27 - --- gnus 5.2.39 --- etc 0.20 --- w3 3.0.11 --- url 1.0.41 --- canna.el patch --- chinese font patch --- stringp nil error when starting sparcworks --- call7 and call8 had incorrect array sizes --- makefile mode Error in `pre-idle-hook' (setting hook to nil): - (void-function makefile-space-face) --- Crashes when built on X11R5 and run on X11R6 fixed --- Lisp backtrace is now printed on all crashes, not just debug build --- XIM input now generates true events. As a result it works with isearch. --- 20.0/Mule can now byte-compile its own elisp files. --- LOTS of typos fixed. --- 20.0/Mule - Language Environment menu no longer shrinks to one element. --- 20.0/Mule - no more Vietnamese language build-time warnings. --- sunpro-init no longer opens /net/bin with possible hang at startup. --- switch-to-buffer-other-window reverted to old-style behaviour --- python-mode 2.72 --- auto-mode-alist regexps reorganized for efficiency --- interpreter-mode-alist regexps now look at entire first line. --- new (interactive) spec `i' can be used to skip arguments. --- dired works in Asian locales. --- (Mule) write-region now works. - -to 20.0 beta26 - --- gnus 5.2.25 --- browse-url 0.38 --- viper 2.90 --- XEmacs web page entries on help menu now reference - browse-url-browser-function --- problem with using dired-mode-font-lock-keywords fixed --- new variable `allow-deletion-of-last-visible-frame' --- NEED_LIBW handled --- glyphs-x.c should really build with older png libs now --- balloon-help crash fixed --- A patch for crash in multiple_change_finish_up which Lars hit. I - don't know if it is fully correct but it should be safe and prevent - the crash. --- some Unixware patches --- some additional SCO patches --- auto-show-mode is now off by default in edit-faces-mode --- incorrect echoing when hitting 'f1 in tty mode fixed --- png build problem fixed --- terminal.el env requirement removed --- gdbglobal doesn't turn on everywhere anymore --- The bug where window-displayed-height didn't always return the - correct value is fixed. The same bug was responsible for - shrink-window-if-larger-than-buffer sometimes failing to work - correctly. --- The force option to delete-frame is back. You can no longer delete - the last visible or iconic frame unless the second arg to - delete-frame is non-nil. --- Darrell Kindred's patch fro the ^@ problem --- a number of random elisp changes from Jamie --- --with-cde flag is back --- revert-buffer no longer causes complete refontification in lazy-lock. --- some more options on Options menu, for Printing. - -to 20.0 beta25 - --- w3 2.3.67 --- url 1.0.34 --- ediff 2.61 --- vm 5.96 --- viper 2.89 --- gnus 5.2.19 --- browse-url 0.36 --- corrected modeline overwriting being triggered by using ispell --- fixed crash in tty-mode with edit-faces (again) --- infinite loop when using surrogate minibuffer fixed --- corrected handling of buffer arg to call-process --- SCO 5 patches from J. Kean Johnston --- patch from Bill Perry to eliminate using temporary files when - handling PNG files --- Sun-provided CDE-friendly icon now default XEmacs icon. --- canna support integrated (Thanks to Moroika Tomohiko). --- apropos.el sync'ed with FSF Emacs 19.31 - Fixes the - `Nothing to follow here' problem. --- set-process-filter no longer crashes if the process is dead. --- x-compose.el now works again on Solaris. --- New function x-keysym-on-keyboard-p helps determine keyboard - characteristics for key rebinding: - - x-keysym-on-keyboard-p: (KEYSYM &optional DEVICE) - -- a built-in function. - Return true if KEYSYM names a key on the keyboard of DEVICE. - More precisely, return true if pressing a physical key - on the keyboard of DEVICE without any modifier keys generates KEYSYM. - Valid keysyms are listed in the files /usr/include/X11/keysymdef.h and in - /usr/lib/X11/XKeysymDB, or whatever the equivalents are on your system. - --- Sun key rebinding changed yet again to use function-key-map. - Type 4 keyboards have r35 mapped to `next'. - Type 5 keyboards already have `next', so map r35 to `kp_next'. --- (Mule) Some menubar items will be translated by default in a - Japanese locale. --- Sun key rebinding changed again to use function-key-map. --- inheritance loops in face property specifications no longer cause - XEmacs to crash. --- minibuffer-setup-hook no longer clobbered by read-file-name. --- extra icons in Info mode removed. --- XEmacs info top level sub-headers synched up with lower-level headers. --- gnuclient prompts you with a dialog box when asking questions. --- the yes/no dialog box now has sane options: yes, no, yes all, no all, - and cancel. --- make-face-bold, make-face-italic, et al. do a better job than before -- - they know about inheritors like [bold] and [italic], and will use - one if their normal X frobbing isn't successful. --- better handling of bad menu filter functions. --- buffers-menu improvements. --- query-replace now disables case-folding if uppercase letters are - in the search string, like isearch does. (To turn both of these off, - set `search-caps-disable-folding' to non-nil.) --- C-h ? ? works. --- Chuck -- you need to re-byte-compile finder.el to fix C-h p under 20.0. - It wouldn't hurt to recompile everything. --- weird bug with markers and standard-output fixed. --- save-options now saves to a file `.xemacs-options' instead of directly - to .emacs. .emacs is set to load .xemacs-options. The file is - loaded with `load-options-file', which will allow eventually for - automatic updating of out-of-date options files. --- Pretty-much everything in that spawn-of-hell file terminfo.c - is commented out now for most systems, since we didn't actually - need any of it! - -to 20.0 beta24 - --- gnus 5.2.12 --- filladapt 2.08 --- fixed padding problem in modeline --- fixed geometry problem with Athena scrollbar; it no longer has any - border and isn't going to at least for 19.14 --- bug where save-places didn't work correctly with a file given on - the command line is fixed --- The global ospeed is completely unused now if TERMIOS is defined. - Before I actually remove the defines (which might fix those header - conflicts) I want some confirmation that doing this doesn't cause - problems in tty mode. This change fixes a crash being seen when - running with the -nw flag on Irix 5.3 (binary built with gcc). --- minibuffer echoing now works properly with surrogate minibuffers --- A number of crashes which were reported when trying to use - surrogate minibuffers are fixed. --- font-lock-add-colors now adds colors and only colors --- --exec-prefix and the other path altering flags should work - NOTE: I have not fully tested it because I would have to do - nothing other than run configure all day to do so. --- It should now work to use XEmacs as a login shell; note that if you - start to stray from a default installation setup this may still be - broken. --- possible fix for Vladimir's crash in Lstream_close(). - -to 20.0 beta23 - --- gnus 5.2.10 --- w3 2.3.65 --- url 1.0.32 --- ispell.el 2.37 --- viper 2.88 --- fixed bug which was leaving modeline droppings next to the scrollbars --- hack from Jamie to make gdb popup a dialog box to answer y/n - questions when using the toolbar --- patch from Bill Perry to eliminate using temporary files when - handling JPEG's --- patch from Bill Perry to support 'pointer extent property --- corrected a bug where annotations in the left outside margin which - were equal to the width of the margin would not be displayed --- Sun keybindings done like in 19.13 - true X keysym always works. --- ispell works - (accept-process-output) bug fixed. --- M-x manual-entry works on SysV with RosettaMan installed. --- process output no longer inserts gratuitious C-d's UNLESS line to - be sent to process is longer than 256 characters. - (This still needs to be fixed so that C-d's are only inserted if - the tty is in canonical mode). --- More type casting fixes to remove compiler warnings. --- Random improvements to the Lisp Reference Manual. --- XIM XCreateIC now always specifies a `Spot Location'. --- If `sparcworks' is not on the PATH, but is in /opt/SUNWspro/bin, - add /opt/SUNWspro/bin to exec-path, and run eos::start. - -to 20.0 beta22 - --- w3 2.3.63 --- url 1.0.31 --- fixed crash in gif_instantiate when starting w3 in tty mode --- fixed crash caused by grayscale jpegs --- patch from Steven Baur to the psgml dtd catalog --- patches to improve Athena scrollbars --- fixes to delbackspace.el --- merged s&m/ files, config*, unex* (mostly), getloadavg.c up to FSF 19.31. - This might fix Lynn's AIX problems. --- better Java font-lock keywords (e.g. tries real hard to fontify - method names in their definitions). --- problems with compiling with --debug=no should be fixed. --- edit-faces in TTY core dump fixed. - -to 20.0 beta21 - --- w3 2.3.61 --- url 1.0.29 --- oo-browser 2.9.12 (adds python support) --- fixed problem with display of right side toolbar --- removed fa-extras.el --- AIX configure patchs --- updated sysdep.el from Bill Perry --- delbackspace.el now uses the new key-translation-map, so it's less - kludgy. --- vrml-mode.el gained some VRML 2.0 support. --- fixed crash in x_output_string triggered by balloon help; this - almost certainly was causing a number of other reported crashes --- fix for "obfuscated and incorrect way of saying 'Solaris'" --- abort() in execute_internal_event() should be fixed --- gnuattach now opens a TTY on *scratch* if given no args. --- gnuattach now passes in the TERM type of the TTY it's run on. --- TTY routines in XEmacs now use filedescs directly instead of FILE *'s; - should fix AIX gnuattach problem. --- VM is smart about whether to install its toolbar on the selected frame - or current buffer. --- new function `set-device-class' (you can say that your TTY device - is color even if it's not apparent from the TERM type) --- selection/unselection of devices/consoles is "idempowered". --- added option for sample.emacs to the Help menu. - -to 20.0 beta20 - --- w3 2.3.54 --- url 1.0.23 --- viper 2.87 --- ediff 2.60 --- more NEWS file updating --- Gnus toolbar is back --- browse-url functions now autoload --- patch from Darrell Kindred to fix auto-show problem with - (set-specifier left-margin-width 10) --- patch from Darrell Kindred to fix isearch buglet --- patch for bad paste of rectangular regions --- fixed crash when starting w3 in TTY mode --- memoize_extent_face_internal() crashes fixed. --- paths.el recomputes salient paths at run-time. --- new function `running-temacs-p'. --- missing functions set-face-strikethru-p, face-strikethru-p added. --- -*- Mode: foo -*- with capital "Mode" wasn't recognized but now is. - (RMS lossage.) --- Obsolete make-cursor added back. --- sample.emacs updated to use new pointer stuff. --- multi-device TTY after X, gnuattach should work properly. --- gnuattach has manpage documentation. --- XEmacs in TTY mode now correctly restores all terminal settings - when exiting. - -to 20.0 beta19 - --- w3 2.3.52 --- url 1.0.21 --- func-menu 2.43 --- pcl-cvs autoloads corrected --- --extra-verbose now implies --verbose as well --- crash in x_get_gc when called from x_output_string should be fixed --- The configure.in code to detect h_errno and sigsetjmp was broken, - unless your compiler supports nested functions (as gcc does). - AC_COMPILE_CHECK takes a FUNCTION BODY, not a FUNCITON, as one of - the arguments. I have some trepidation on making these changes as - there are some comments in solaris header files about disabling - sigsetjmp, but at least the configure test now works - and XEmacs - still seems to, too. --- Sun support in configure.in has been rewritten. SunOS 4.1.1 through - 4.1.4 has been tested. The configure code for suns has been greatly - simplified. --- Xmu detection should now work on SunOS4. - -to 20.0 beta18 - --- pcl-cvs 1.7 ; please test --- w3 2.3.43 --- url 1.0.20 --- ediff 2.59 (again; this should have a higher rev) --- follow 1.6 --- config.guess and config.sub updating; may cause some configuration - problems --- dynamic or lack thereof lazy-lock bug fixed --- word-search-{forward,backward} crash fixed --- easymenu.el patch from Per Abrahamsen --- ClearCase VC support from Rod Whitby --- lib-complete now dumped; improved find-library --- make-x-device patch for TTY mode from Bill Perry --- extent-faces-as-list lossage patch from Bill Perry --- multiple definition cleanup --- mailcrypt update for sgnus --- new function isearch-toggle-case-fold --- new function device-sound-enabled-p --- background.el lossage fixed --- find-dired lossage fixed --- if XEmacs cannot deduce a bold-italic font from the default, try - copying the bold face and doing make-face-italic - if that fails, - try copying the italic face and doing make-face-bold. With the - XResources in the bug report, I get the correct fonts now - please - try. --- default-popup-menu now intelligently greys out its menu items --- don't put up the load .emacs button in the menubar if the file - doesn't exist --- actually let the 'Frame-local font menu' work! The call to - (set-face-font 'default ...) was not specifying the frame as a - locale, so all changes to that face were global. --- more bugs fixed, including some for core dumps. If there are any - remaining core dumps in b18, please yell so that they get fixed. --- `pointer' face works now. --- `colorize-image-instance' changed incompatibly (previously it did - bad things). I don't think this matters because no one seems to - use this function anyway. --- browse-url 0.30 (includes Lynx support) --- updated f90.el --- cperl-mode (although not enabled by default) --- skeleton.el --- improved Linux native sound support --- updated PROBLEMS (synched with 19.30) --- CDE autodetected. --- initial unification of browser-sending support. --- fixes to focus handling -- should fix "delay noticing focus change after VM - invoked" --- uses ncurses if available -- better terminal support. --- if you have color xterm and set your TERM to xterm-color, - XEmacs will use color on TTY's (at least under Linux). - Under linux, TERM=linux or TERM=ansi also has this effect. - (In general, any terminal type that defines color capabilities - in terminfo.) - -to 20.0 beta17 - --- w3 2.3.42 --- url 1.0.19 --- mh-e 5.0.2 --- XIM work from Martin --- electric modes synched up with FSF 19.30(.97). --- func-menu 2.41. --- no cursor blink at eol fixed --- lots more bugs fixed, see the Web page. --- more TTY colors. --- new last-win and next-win icons. --- VRML mode (I wrote it). --- SPC does its previous thingie in the minibuffer. --- curmudgeon mode is removed. - -to 20.0 beta16 - --- w3 2.3.39 --- url 1.0.17 --- curmudgeon-mode: Just so all you curmudgeons will shut up. - `enable-curmudgeon-mode' sets all the old minibuffer, etc. behavior - that you're used to. You can also give a particular category for - curmudgeonization. --- func-menu 2.38. --- enriched.el, face-menu.el from Michael Sperber. --- If you're in a help buffer, you can exit using q and the previous - window config is restored. Help buffers are now selected by default - to make this easier (but you can get the old behavior using - curmudgeon mode). --- `eq' now works on face properties even if they're lists -- the - lists are "memoized". --- numerous bugs fixed -- see the Web page. - -to 20.0 beta15 - -READ THIS FIRST: - --- emacs-version for 20.0 now reports 20.0, not 19.20. This is gonna - break some packages that do incorrect version tests. Both 19.14 - and 20.0 now include the function `emacs-version>=' from emacs-vers.el, - which is a correct version test function. If you want to use this - (highly recommended!), put code in your file like - - (or (fboundp 'emacs-version>=) - [copy definition of emacs-version>= from version.el]) --- Byte code emitted by XEmacs 20.0 is NOT, repeat NOT, downward - compatible. Byte code compiled in any Emacs 19 is upwardly - compatible to v20. (For the most part, that is ...) However, - you can force v19 compatibility under XEmacs 20 by setting - `byte-compile-emacs19-compatibility' to non-nil. --- (This latter change is the result of a better solution to the - "char-int confoundance syndrome" problem, although it was - planned anyway.) - -USER-VISIBLE CHANGES: - --- w3 2.3.36 --- url 1.0.16 --- viper 2.86 --- ediff 2.59 --- cc-mode 4.282 --- func-menu 2.37 --- mailcrypt 3.4 (2.x has been removed) --- The appropriate function-key and arrow-key definitions should - now be set up automatically in TTY mode, for a number of different - terminal types. Please review the terminals in lisp/term/ and - see if there's anything wrong. Also, feel free to supply new - terminal definition files. --- blink-cursor-mode. This gets you the blinking cursor that lots - of people have been wanting for awhile. There is a menubar - entry for this. - NOTE: There is currently a redisplay bug whereby the cursor - won't blink if it's at the end of the line. Hopefully Chuck - will fix this soon. --- wing-psgml-mode: A "grand unified mode" for HTML. I started out - with PSGML, which is a way cool and powerful mode for editing SGML, - but extremely un-user-friendly in its current form. I combined it - with some setup stuff from Alastair Burt and took some stuff - (the template stuff) from the hm--html-menus package. --- improved file-dialog-box; some help from Rich Williams here. --- improved completion-list-mode. (This is the mode for the lists - of completions.) Hit SPC in the minibuffer and you'll end up in - the completion list buffer, and can move around and select things - in a sensible fashion. This should be a friendliness improvement - for TTY mode and such. --- improved edit-faces. It uses the new list-mode also and has - other new user-friendly features. --- auto-show mode is now dumped and is enabled by default. This - will automatically scroll the window horizontally as necessary - to keep point in view. (buff-menu is no longer dumped, so there's - a net decrease in the puresize.) --- There is a menubar entry for Bookmarks. --- `show-message-log' and the associated menubar entry no longer exist. - Instead, use `view-lossage' (C-h l). There is now a menubar entry - for this under Help. --- etags is merged with FSF 19.30 (adding Perl support, among other - things), and some Mly-induced breakage that resulted in pathologically - long relative filenames in the TAGS file has been fixed. --- tcl.el 1.50. --- annoying VM auto-raise of frame is gone. --- I fixed a number of bugs with this-command-keys and C-g. - e.g. the C-x ? C-x C-h bug is finally gone. If you see any more, - please pipe up and I will try to fix them. (A lot of the event code - is rotting, though, so not everything can be fixed ...) Also, if - you notice any weird behavior, *please* speak up! - -BUILD-LEVEL CHANGES: - --- When XEMACS_DEBUG is defined and XEmacs is dumping, the number of - bytes of purespace used by each loaded file is displayed. --- Linux no longer defines BROKEN_SIGIO. --- Linux binutils-2.6.0.10 breakage is no longer. --- fixes for building under SunOS. --- configuring without database support now works. --- you can fix up the autoloads using `make autoloads' in the top - level directory. - -LISP-LEVEL CHANGES: - --- Hyperbole is still broken, sigh. --- function-key-map and key-translation-map are now properly implemented. --- keyboard-translate-table now lets you translate keysyms, e.g. to - fix the grievous damage Sun did to their X keyboards. See the - function `keyboard-translate'. --- The function `window-height' has been changed to return a different - value when a horizontal scrollbar is present. The new definition - makes window-height ``mathematically tractable'': Its value always - reflects the window geometry, and will not change if you turn off - or on the modeline or horizontal scrollbar. Also, now, when there - is only one window, frame-height always equals window-height. --- The new function `window-displayed-height' returns the actual - number of text lines currently visible (making proper allowances - for blank space at the end of a buffer). You should use this - instead of the standard kludge `(1- (window-height))'. --- Hash tables can now do their comparisons with `equal' instead of - `eq'. See `make-hashtable'. --- The `face' property of extents and text properties can now be - a list. --- derived.el has been fixed up and is now dumped. --- cl.el is now dumped. This includes the most basic of the - Common Lisp functionality; the rest is autoloaded. (And with - the lazy byte-code loading, it will come in only as needed.) - Accordingly, I removed the (usually less powerful) XEmacs versions - of `intersection', `union', etc., `delete-if', `delete-if-not', - `push', `pop', `c[ad][ad][ad]?[ad]?r', etc. This should clear - up any remaining problems with ediff and such. Note that the - increase in purespace from doing this is actually quite small -- - about 15K. --- At least one function (`display-completion-list') has been rewritten - to take Common Lisp key-style arguments. This provides a sensible - alternative to having zillions of optional arguments in an - unrememberable order. Other packages might consider doing the - same. --- completion-list-mode is actually defined using `define-derived-mode', - as a sub-mode of list-mode. edit-faces defines another sub-mode - of list-mode. --- some patches from Darrell Kindred. --- new specifier `text-cursor-visible-p' controls whether the cursor - is visible. --- new face `text-cursor' controls the colors of the text cursor. --- New file `gui.el' defining some functions useful for GUI stuff, - e.g. creating dialog frames and buttons. --- The function `extent-at' now takes an argument AT-FLAG controlling - what it means for an extent to be "at" a position. `get-char-property' - and `get-text-property' also take that argument. --- `display-completion-list' has been changed to take key-type optional - arguments. There are keys for controlling the activation callback, - the help string displayed, the window width, and other things. --- New text-property functions `text-property-bounds' and - `next-text-property-bounds' facilitate looking for stretches of - specially-marked text. This supersedes the common, error-prone - loops involving `next-single-property-change', `map-extents', etc. - (I thought long and hard about the end cases.) --- `frame-visible-p' now actually queries the window system, so it - is always accurate without the need for weird kludges like - `accept-process-output'. - -MISC CHANGES: - --- Glyph and keymap lispref documentation should now be accurate - and up-to-date. --- XEmacs uses sigsetjmp(foo, 0) when possible; this avoids lots - of sigprocmask() system calls that were happening. - -to 20.0 beta14 - --- w3 2.3.32 --- XEmacs has a pseudo-file-dialog-box that gets invoked when you - choose a menu entry that prompts for a filename. The code that - implements it is in `mouse-read-file-name-1' in minibuf.el. - It's a pretty cheesy-ass function but it gets the job done. - It clearly needs some work; beta testers out there are encouraged - to help here. (hint, hint) --- there were some missing UNGCPRO's that might have led to weird - crashes. --- Much improved xemacs-internals. More is coming. --- lots of improvements to the Lispref documentation, e.g. the general - section on objects is now actually more or less correct. --- "cursor glyphs" and "cursor image instances" now use the term - "pointer" instead of "cursor". --- new profiling code. See `start-profiling', `stop-profiling', - `clear-profiling', `pretty-print-profiling-info', etc. - This uses a SIGPROF so it's only as accurate as your system timer - (100Hz under Linux on the x86; may be different on other systems). --- I have tried hard to minimize the amount of allocation that happens - as a result of normal activities. For example, `save-window-excursion' - and `save-excursion' no longer result in any allocation in most - circumstances. --- New variable `debug-allocation'. If you set this to non-zero, you - will get a record on stderr of every time that any allocation occurs, - and a short backtrace will accompany it (controlled by - `debug-allocation-backtrace-length'). Normally, set this to 1; - if you set this greater than 1, you'll also see the "noseeum" allocations - that happen internally and are later undone (thus causing no net - allocation). --- byte-code objects print more sanely. They also have an "annotation" - field indicating where they came from. --- problem with lazy-lock sucking away idle time should be gone. --- problem with mouse highlight not appearing may be gone. --- problem with "interactive `e'" incorrect is fixed. --- you can set and access all specifier and glyph variables using - frame properties. - -to 20.0 beta13 - --- mode-motion+.el 3.15 --- hm--html-menus 4.16 --- ediff 2.54 --- viper 2.85 --- w3 2.3.30 --- url 1.0.13 --- nil is once again a valid color instantiator --- 'make install' in a clean workspace should now work correctly. --- Fixed a bug where using proportional fonts for the default face resulted - in an extra-wide frame. --- Fixed wrong-type-argument error when using 'delete window above' from - modeline menu. --- Fixed error when loading nroff-mode. --- Fixed crash caused by this: - (setq toolbar-file-icon '(blah)), then C-x b foo RET --- Error signaled if you try to create a frame with a `.' in the name. --- frame size changes which occur while a tty-mode XEmacs is suspended are - now handled. --- super-apropos is now apropos-documentation ; Help menu has been changed --- tooltalk patch to allow setting of message disposition attribute (from - Hans Muller) --- user-mail-address patch from Russell Ritchie --- DEC OSF 4.0 patch from Manoj Srivastava --- new specifiers default-toolbar-height, default-toolbar-width, - default-toolbar-visible-p, and {top,bottom,left,right}-toolbar-visible-p. - The new default specifiers work like default-toolbar: for whichever of - the four positions is the default-toolbar-position, the corresponding - specifiers foo-toolbar, foo-toolbar-{height,width}, foo-toolbar-visible-p - inherit from the appropriate defaults if no value is given. I also redid - the toolbar size-handling code. This appears to fix the weird problems - Kyle noticed with VM and the prev/next window config buttons, and might - have fixed that elusive VM phantom toolbar bug. - -to 20.0 beta12 - --- gnus 5.0.15 --- cc-mode 4.281 --- now works in TTY mode, yay. --- removed ill-conceived FSF Emacs post-command-idle-hook (added to - XEmacs in an earlier beta). Replaced it with pre-idle-hook. - lazy-lock now uses this. --- added frame-modified-tick for use by lazy-lock. --- cursor overhaul is here. Cursors are now specifiers. Should make - them work properly on multiple devices. Not working quite yet: - colored cursors. I'll get to these. --- various fixes, e.g. to font-lock. --- cc-mode 4.280 --- dialog boxes work again. (e.g. Save-some-buffers from the File menu - works and uses the new-improved map-ynp stuff.) --- I changed `set-specifier' so that it works more sensibly - (like `set-face-property' -- it takes a separate LOCALE and - TAG-SET argument, although the old way of specifying things - still works) and rewrote the incomprehensible gibberish that - masqueraded as its documentation so that it actually makes - sense now, even to someone who's not especially familiar with - specifiers. - -to 20.0 beta11 - --- follow.el 1.5 --- oo-browser 2.9.11 --- hyperbole 4.01 --- w3 2.3.28 --- pretty much all reported bugs for the last betas should be fixed. --- event crash from "M-x followed by mouse click" fixed. --- fixed a nastily subtle bug in `kill-all-local-variables' that has - been around since mly's symbol rewrite some two years ago. This - bug could potentially have resulted in all sorts of inconsistent - and difficult-to-track behavioral problems. --- fixed another nastily subtle bug that had to do with extent - parents/children. This feature should finally work correctly now, - because it's actually being used (in the modeline). --- exported weak list interface (new functions `weak-list-p', - `make-weak-list', `weak-list-type', `weak-list-list', - `set-weak-list-list') so I could test it -- it's used in extents - to fix that nastily subtle bug just mentioned. --- I removed the disgusting "feature" of being able to use `elt', - `concat', `length', etc. on compiled-function objects, and fixed - the small number of places that relied on this. However, if you see - an error of the sort - - As of 19.14, `foobar' no longer works with compiled-function objects - - then I missed a place. - - Note that there are accessors `compiled-function-*' for properly - accessing the contents of a compiled-function object. These - accessors have been around since at least 19.8, so this is not - an overly bold change to make. - - NB: Chuck says the cruddy `aref' stuff is going back into 19.14, - but will disappear for good in 19.15. --- you can now dump faces into the dumped XEmacs. --- modeline changes: - -- The (GLYPH . KEYMAP) and (FACE . FOO) modeline specs have gone - away. In place of this, use (EXTENT . FOO). The face, keymap, - and help-echo properties of the extent are noticed. Nested - keymaps are handled correctly, but not nested faces as yet. - See `modeline-format' and `generated-modeline-string' for - details about how this all works. It's way cool. - -- colored sections of the modeline generally indicate that you can - "do something" with button2 or button3. button2 does something - immediately while button3 brings up a menu. (Clicking button2 - on a non-colored section of the modeline does nothing, while - clicking button3 there brings up the standard modeline menu.) - -- clicking button2 on the "read-only" marker toggles read-only status. - -- clicking button2 on the right half of the buffer ID (the part that - says " foobar.c") cycles to the next buffer. - -- clicking button2 on the left half of the buffer ID (the part that - says "XEmacs:") cycles to the previous buffer. - -- clicking button3 anywhere on the buffer ID brings up a Buffers - menu. - -- clicking button2 on the ID strings of certain minor modes turns - them off (such modes are displayed in green instead of red). - ("Certain minor modes" means minor modes that correctly call - `add-minor-mode' to announce themselves instead of just - smashing minor-mode-alist directly. I've fixed some modes to - do this.) - -- clicking button3 on any mode ID string brings up a menu that lets - you toggle certain minor modes. (#### Should also let you change - the major mode. How do you get a list of all major modes that - exist, sans the uninteresting ones?) - -- clicking button2 on the "Narrow" string of a narrowed buffer - widens the buffer. - -- help-echo is given for all button2 actions. --- save-options wraps its outputted forms in (if (featurep 'foo)) to - make sure that your .emacs will load OK in a differently-featured - XEmacs from what you saved the options in. --- new function `set-face-parent' for properly making one face inherit - all attributes from another. --- `set-extent-endpoints' can be used to move an extent from one - buffer to another. --- semi-new function `event-glyph' returns the glyph underneath an - extent. --- fixed bug in `recover-session' ... tsk tsk beta testers. --- new function `mapc' -- like mapcar but doesn't accumulate results. --- switched back to newer version of paragraphs.el; corrected - filladapt.el to mesh properly with it. --- now autodetects -lgdbm as well as -ldbm, and uses the appropriate - one. The --with-database option takes a comma-separated list - of one or more of "dbm", "gnudbm", and "berkdb", or "no" to - disable. --- autodetects png, both with -lz and -lgz. You can explicitly - call for png with -lgz using --with-png=gnuz. --- autodetects libXmu absence. --- configure option for NO_UNION_TYPE enabling/disabling provided. - It's called --use-union-type. WARNING: GCC (esp. 2.6.0, 2.6.3, - 2.7.0) will probably fuck up and generate incorrect code if - you use this option. --- finally repaired the grievous damage that is `frame-parameters' -- - use `frame-property', `frame-properties', `set-frame-property', - and `set-frame-properties' instead. `frame-parameters' and - `modify-frame-parameters' are still supported but obsolete. - - "Frame properties" are not only a different interface but actually - let you store arbitrary properties along with a frame, and - retrieve them later. - - `frame-property' is much more efficient than `frame-parameters' - because it is non-consing. --- new functions `alist-to-plist', `plist-to-alist', - `destructive-alist-to-plist', and `destructive-plist-to-alist' - to make it easier for you to convert between alists and plists, - such as you might do with frame properties/parameters. --- A whole host of new functions for working with plists. - There is also a parallel set of these functions for "lax plists", - which are plists where comparison between keys is done with `equal' - instead of `eq'. (Frame property plists are this way because the - keys can be strings.) --- The monstrous spawn-of-hell function `display-buffer' has been - moved into Lisp, so you can play around with it if you want - to. --- New functions `push-window-configuration', `pop-window-configuration', - `unpop-window-configuration'. The latter two implement a - Netscape-like forward/back movement through window configurations. - `display-buffer' automatically pushes a window config if anything - changes as a result of the call, so you can easily undo the results - of asking for help and such with just a mouse click. - - PLEASE someone come up with better icons. I just stole the Info - arrows. --- The dreaded FSF dynamic byte-compile format is here. It is *NOT* - repeat *NOT* enabled by default for 19.14, so it's not gonna - break anything. It *IS* yes that's right *IS* the default for - 20.0. (Both kinds of dynamic byte-compiling are the default - for 20.0.) Therefore, files you compile using 20.0 won't be - readable under versions before 19.14 unless you set - `byte-compile-dynamic' and `byte-compile-dynamic-docstrings' - to nil before compiling. Note that 19.14 will recognize - and correctly read dynamic byte-compiled files (whether compiled - by 20.0, 19.14, or FSF 19.29 or above), even though it won't - generate them by default. (You have to set one or both of - those variables just mentioned to non-nil if you want this.) - -to 20.0 beta10 - --- cc-mode 4.273 (includes java-mode from Eduardo) --- edebug 3.5 --- first line display problem on ttys fixed --- problem with cursor position after exiting tty mode fixed --- cheap fix for the filladapt problem; completely backed out the sync - of paragraphs.el with 19.30. One of the changes in - forward-paragraph is causing the problem. --- Faces can now be embedded in the modeline. Add a cons where the - car is a face object and the cdr will be evaluated as usual but the - results of it will be displayed in the given face. --- Glyphs can now be embedded in the modeline, along with a keymap to - make them active. For a glyph which just displays you can insert - just the glyph. To include a keymap, add a cons with the car as - the glyph object and the cdr as the keymap object. --- cut redisplay's memory consumption by 1/3 --- fixed a memory leak in the scrollbar code --- font-lock basically synched with 19.30. - LISTEN UP: I changed the way font-lock faces are initialized. It - now takes advantage of the specifier stuff added in 19.12, and sets - up color defaults for color machines and non-color defaults for - non-color machines. The defaults are added with `append', which - means that if you add your own values, they'll override the defaults - regardless of when you do it. - - SO: Please try temporarily disabling all your font-lock customizations - and comment on what you think of the new defaults. --- major DUH factor. The cause of the 10%-CPU-usage-while-XEmacs-is-idle - was that the "quarter-second timer" was actually set to fire - 1000 times per second. I think I must have changed this at one - point to debug something, and never set it back. Oops ... - If you set `debug-emacs-events' to non-zero on a Linux or IRIX - machine, you'll now see blank eval events going by at a reasonable - rate (4 times per second) instead of spewing out like water from - a firehose. --- yet more synching with FSF 19.30. --- Lots of modes have gained menus. --- recover-session (recovers all auto-saved files) should work. - Not really tested. --- latest apropos.el from 19.30. Implements some of what Hyper-Apropos does. - Maybe we should junk apropos.el or integrate the two. --- `display-buffer' synched with FSF 19.30. This gives you the following - wondrous cruft: - -- unsplittable frames - -- pop-up-frames, pop-up-frame-function - -- special-display-buffer-names, special-display-regexps, - special-display-function - -- same-window-buffer-names, same-window-regexps --- finally! C-h k followed by a toolbar button press correctly reports - the binding of the toolbar button. --- fixed problems with toolbar buttons remaining activated or C-g being - pressed during minibuffer prompting of (e.g.) toolbar Replace or Open --- fixed "Error setting GC pointer" problems. --- text-property problems reported by Alastair Burt fixed. --- ediff minibuffer weirdness fixed. Surrogate minibuffers are working. --- ~ has electric behavior like / in minibuffer. Both of these can be - inhibited by setting `minibuffer-electric-file-name-behavior' to nil. --- minibuffer completion lists are put into a special mode. left, right - move to the next/previous completion. enter selects the completion. - button2 selects, as always, but will always be accurate as to the - completion -- no regexp-based guesswork, as before. --- the kludgy completion-tracking behavior that looks for completions - under the mouse has been disabled. If you want it back, set - `minibuffer-smart-completion-tracking-behavior'. This does *not* - affect the normal ability to click on a completion in the - *Completions* buffer. Turning this off should also fix the obnoxious - "mouse motion causes ange-ftp action" bug. --- ported latest map-ynp.el. Used by `save-some-buffers'. --- Bill Perry's database and strikethru patches. - -to 20.0 beta9 - --- w3 2.3.26 --- crash caused by corrupting toolbar icon specs is fixed --- no one complained, so I removed `local-pre-command-hook' and - `local-post-command-hook'. --- follow-mode 1.5 beta (01-08-96); this lets you turn two side-by-side - windows into one twice-as-long "virtual buffer". --- more synching with FSF 19.30. --- ange-ftp should work. --- new configure option --with-term, for support for TERM (Linux serial-port - multiplexer), for those who care. The support was already present - in XEmacs, just no configure option. --- jpeg code now just includes "jpeglib.h" instead of "jpeg/jpeglib.h", - and configure autodetects likewise. --- new variable debug-emacs-events. Set to non-zero to have all events - seen by XEmacs output on stderr. (From this, I know what's going on -- - it's the 1/4 second timers for when SIGIO and/or SIGCHLD are broken. - It can be fixed, but not until the next beta ...) --- overriding-terminal-local-map and other oddities from FSF. --- added some of the necessary C support for lazy-lock v2. --- ange-ftp works around a Linux FTP problem where it outputs escape - sequences to highlight the ftp prompt, which messes things up. --- I changed a couple ange-ftp defaults: - -- ange-ftp-generate-anonymous-password is t. I see no reason - why you should have to type in a password here. - -- ange-ftp-default-user is "anonymous". This one is more - debatable, but I think it's a lot more logical (more like - ncftp, too) and follows the Principle of Least Surprise. - Differing opinions (except from Kyle Jones :) are welcome. --- Info menu now properly disappears when you exit Info. --- new functions frame-leftmost-window, frame-rightmost-window. --- next-frame and previous-frame have been expanded and unkludgified - to allow you more control over which frames are considered. --- Bill Perry's GIF and PNG patches are included. --- Various patches for the DEC Alpha and other beta-list patches - are in place. --- function to access the raw window tree have been added: - window-first-hchild, window-first-vchild, window-next-child, - window-previous-child, window-parent. These let you implement - frame-leftmost-window and lots of similar functions. --- XEmacs should be more robust about dying properly when crashes - occur. --- you can compile with Epoch support. (Actually, you could in the - previous beta, too.) The main thing this gets you is direct - access to some X events and objects (e.g. properties and - property-notify events). --- you can set initial-frame-alist in your .emacs, and XEmacs will - notice this and change the initial frame accordingly. --- major revamping of the multi-device support: - -- there is a new type of object called a "console". A console - groups together devices that have the same keyboard/mouse. - A "device" now corresponds to an X "Screen", while a "console" - corresponds to an X "display". You don't need to explicitly - create a console; it's created as necessary when you create - a device. - -- device-local variables have become console-local variables. - -- "device types" are now "console types", although functions - that speak of "device types" and "frame types" are defined - as aliases. - -- devices are no longer permanent objects, but remain around - only so long as there are frames on the device. Consoles - behave similarly. (#### not implemented yet; wait for - next beta) - -- Devices and consoles have a generalized concept of a - "connection", which describes what they are connected to - (e.g. a DISPLAY for an X console, a tty name for a TTY - console). Calling `make-device' on an existing connection - returns an existing device and/or console rather than - creating a new one. The code is also quite smart about - determining whether a connection refers to an existing - device or console; e.g. if your machine name is "nene.666.com" - alias "wing.vip.best.com" address 204.156.158.101, then - all of the following display specs are treated as equivalent: - - unix:0 - :0.0 - localhost:0 - nene:0 - nene.666.com:0.0 - wing.vip.best.com:0 - 204.156.158.101:0 - - -- To retrieve a device or console's connection, use - `device-connection' or `console-connection'. - 'device-x-display' and 'device-tty-tty' are no more. - -- 'device-tty-terminal-type' renamed to `console-tty-terminal-type'. - -- To search for a console or device by connection, use - `find-console', `find-device', `get-console', or `get-device'. - - -to 20.0 beta8 - --- w3 2.3.25 --- url 1.0.12 --- viper 2.85 --- func-menu 2.35 --- SCO patches from Robert Lipe --- XEmacs has a man page, finally. --- lots of updates to the lispref docs. --- s/, m/, and configure files synched with FSF 19.30. --- extents-over-strings complete. Extent replicas are no more. - You can get the same functionality by setting the `replicating' - property on an extent. --- describe-mode puts major modes first (from Stig) --- device-local variables are here. A few variables are currently device- - local; eventually the whole command builder will be this way. - New function `symbol-value-in-device'. Functions - `device-function-key-map' and `set-device-function-key-map' have - been removed. `function-key-map' is instead a device-local variable, - with a default `default-function-key-map'. --- XEmacs now preloads all code at dump time (except for some terminal- - or X-server-specific files, for which it's not fatal if they can't - be found). Thus, you can delete the lisp directory if you really - really want to. --- `open-dribble-file' works. --- Info has a pulldown menu. --- function `extent-descendants'. --- you should be able to compile without scrollbars, menubars, and/or - dialog boxes. This has been somewhat tested but may not work with - all possible configurations. More testing would be appreciated. --- there are better feature-tests available: to check for the presence - of menubars, scrollbars, dialogs, and/or toolbars, use `featurep' - with `menubar', `scrollbar', `dialog', or `toolbar'. There are also - features `lucid-menubars', `athena-scrollbars', `motif-dialogs', etc. - etc. for whatever configuration you compiled in. --- SPARCworks CYA message is only displayed if (featurep 'sparcworks). --- lots of other stuff merged with FSF 19.30. Change list: - -- Key changes: - -- C-x ESC -> C-x ESC ESC - -- ESC ESC -> ESC : - -- ESC ESC ESC is "abort anything" (keyboard-escape-quit). - -- indirect buffers. These are buffers that share text with another - buffer but have their own major mode, extents, buffer-local variables, - etc. Create with `make-indirect-buffer'. See also - `buffer-base-buffer', `buffer-indirect-children'. (Not yet - finished implementing.) - -- new function `set-buffer-major-mode'. - -- `buffer-invisibility-spec' controls whether the `invisible' property - is applicable. - -- `inhibit-read-only' can be a list of property values; similar to - `buffer-invisibility-spec'. - -- new "file format" concept. See `buffer-file-format', - `format-alist', `format-decode', `format-encode', - `insert-file-contents-literally', etc. - -- `call-process' can have a separate stderr specified. - -- Junky variables `self-insert-face' and `self-insert-face-command'. - -- `write-region' can take a sixth argument LOCKNAME (a lock file). - -- new function `find-alternate-file-other-window'. - -- improved margin functions -- `current-left-margin', etc. - -- newlines can be "hard" or "soft" -- I guess this affects filling, - paragraphs, etc. See `use-hard-newlines'. - -- lots and lots of filling / justification / paragraph changes. - -- `shell-command' and related can take optional output buffer - specification. - -- `what-line' prints more information. - -- new functions `file-writable-p', `file-regular-p'. - -- new function `active-minibuffer-window'. - -- new function `cancel-kbd-macro-events'. - -- new functions `run-hook-with-args-until-success', - new functions `run-hook-with-args-until-failure'. - -- generalized facility for local vs. global hooks. - See `make-local-hook', `add-hook'. - -- signal-process can take a symbolic name for the signal. - - -to 20.0 beta7 - --- Gnus 5.0.13 --- W3 2.3.24 --- url 1.0.11 --- viper 2.84 --- ediff 2.51 --- added .f90 to auto-mode-alist --- fixed problem with echo area redisplaying during macro execution --- first version of "gnuattach", for viewing a file in the current - TTY frame. Works like gnuclient. I did a "good enough" implementation - because I don't understand fully how gnuserv works. Someone else - might want to take a look at it. --- fixed problems with bad cc-mode indentation --- fixed ^G problems, likely fix for "XEmacs consumes too much CPU" --- undo in the minibuffer. --- problems with tight loop in sys_readdir() should be fixed. --- char-tables are now readable; Bill Perry's eval-when-compile problem - should be fixed. --- the unified range table code is now defensive about getting itself - misaligned, so it should work no matter what tricks realloc() plays. - This should fix the assertion failure, line 621 of rangetab.c. --- next-window, previous-window, next-frame, previous-frame, other-window, - get-lru-window, etc. extended to take a device argument that allows - you to restrict which devices it includes (normally all devices). - Some functions that incorrectly ignored frames on different devices - (e.g. C-x 0) are fixed. --- start-open, end-open, start-closed, end-closed now work correctly - w.r.t. text properties. (This is apparently required by GNUS 5.) --- implementation of extents over strings is close to being done. - You can now go ahead and create extents over strings but they aren't - yet properly copied from string to string or between strings and buffers. --- new function `extent-list'. - -to 20.0 beta6 - --- Gnus 5.0.12 --- w3 2.3.18 --- viper 2.82 --- ediff 2.49 --- lazy-lock 1.14 --- func-menu 2.34 --- mode-motion+ 3.14 --- patch from Bill Perry fro tty_valid_color_name_p --- mode-motion patch from Michael Sperber to eliminate "evil ftp activity" --- we check for interrupted system calls in opendir(), readdir(), - closedir(); this should eliminate the "interrupted-system-call" - errors people have been seeing with completion. --- GIF support! Since there appears to be no standard GIF library, - and since the code I found (giflib-2.2 from the Linux archives) - is quite small, I just put it in the XEmacs src directory. - NOTE: If you encounter problems with certain GIFs (e.g. interlaced), - let me know and I'll enable some currently dormant code. - NOTE: For the moment, GIF support is enabled everywhere because it - requires no special libraries or machine-dependent features. You - can disable it using --with-gif=no. --- JPEG support! Compile with --with-jpeg (or just let it be - autodetected). You need to obtain the standard JPEG library (libjpeg) - from the Independent JPEG Group. One source is ftp.uu.net:/graphics. - Compiled Linux libraries (not the most recent version, but they work - fine) are available at sunsite.unc.edu:/libs/graphics. You have to - specify the location of the libraries and include files using - --site-libraries and --site-includes. Note that the include files - are presumed to be in a subdirectory "jpeg" of the --site-includes - directory. --- Lstreams free their buffers when they are closed rather than - when they are GC'd. This should avoid the memory bloatage noticed - when you repeatedly insert a lot of files, and should render - unnecessary the patch that Darrell Kindred submitted. --- patch for possibly deadly Mule problem --- XEmacs behaves reasonably in the presence of a bogus app-defaults - file --- configure debugging: if you specify --extra-verbose, then any - error messages from compilation and preprocessor feature tests - will be output. This is especially useful if your feature tests - are failing for no obvious reason. #### Suggestions for a better - name than --extra-verbose are welcome. --- warning messages will get generated if there is a problem displaying - an image, rather than just nothing happening at all. --- You can disable toolbar support by specifying --with-toolbars=no. - This should reduce the code size a bit. --- You can disable TTY support by specifying --with-tty=no. - This should reduce the code size a bit. --- The oddly named "dont-have-xmu=yes" option is now "with-xmu=no". --- loaddefs and keydefs are now compiled like other Lisp files. --- You should get more accurate errors for many types of mistakes - with set-face-* functions. - -to 20.0 beta5 - --- Gnus 5.0.7 --- w3 2.3.4 --- url 1.0.3 --- patches from John Hughes to make 8-bit TTY - input and TTY function keys work better. You may get undefined - references to _sobuf; if so, change the glump around line 1404 - of sysdep.c. (for 19.14.) --- configure autodetects the sun_len member in struct sockaddr_un. - (for 19.14.) --- likely fix for regex crashes on some systems. (for 19.14.) --- fixed problems with skip-syntax-forward. (for 19.14.) --- TTY color should behave better. (for 19.14.) - Try this under TTY XEmacs and you'll see what I mean: - - (set-face-foreground 'default "magenta") - (set-face-background 'default "cyan") - -to 20.0 beta4 - --- cutting and pasting of extended text to/from other applications works - properly: the text is correctly converted to/from Compound Text format. --- Short-form fonts like 6x13 should work under Mule. --- New configure option --with-mocklisp for Mocklisp support. (for 19.14.) --- TTY support should now be working properly under Mule. - If you are running under kterm, you should see the Japanese - characters in the tutorial properly. --- TTY colors! New functions `register-tty-color', `unregister-tty-color', - `find-tty-color', and `tty-color-list' for specifying the valid TTY - colors. Of course, you need a terminal that is capable - of handling ANSI color sequences, e.g. Color XTerm or the Linux console. - The standard ANSI colors (black, red, green, yellow, blue, cyan, - magenta, and white) are registered by default so you can just go - ahead and use them. (for 19.14.) --- Netscape begone! XEmacs *really* handles colors properly given a - full colormap. (for 19.14) - -to 20.0 beta3 - --- new version of f90.el; .f90 files now invoke f90-mode --- hm--html-menus 4.15 --- w3 2.3.2 --- url 1.0.1 --- Japanese input (Hiragana, Katakana, Kanji) is working under Mule. - The SKK input method has been ported and should be available - on the ftp site. - - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - WE NEED BETA TESTERS. - - Tell all your Japanese-speaking friends. - Where are all the Japanese-speaking people when we need them? - Actually, with a little work, someone should be able to get - Quail working, which allows for input of all sorts of languages. - --- new function `current-process-time' for retrieving the user, system, - and real times of the currently running XEmacs process. (for 19.14 - probably.) --- Here's a cool new demo that works under Mule: Load the file - `mule-doc/demo'. This has "hello" written in a zillion different - languages / charsets. Astute observers will notice two problems: - (1) Half of the Thai characters don't show up. That's because - composite characters still aren't displayed properly. - (2) The Arabic and Hebrew characters go backwards from the way - they should. (Guess why?) --- error-handling behavior in Mule decoding (e.g. unknown charset) - should be much better. The goal here is that there should never be - any information lossage when a file is read in, decoded, encoded - again, and written out. If escape sequences get transformed into - some other equivalent escape sequence, that is OK; but if they - get eaten, that is not OK. --- translation tables are handled consistently (note, I didn't say - "correctly") under Mule. Doing them correctly is very difficult - so I'm punting for now. Basically, under Mule, `upcase' and - `downcase' (and related) work correctly with translation tables - but the string/buffer-searching routines will ignore translations - that map to or from a character not in the seven-bit ASCII - range -- thus `case-fold-search' will not correctly conflate - a-umlaut and A-umlaut. This sucks, but it's better than the - alternative (weird results and possible crashes). --- regex searches/matches should work properly with extended - chars under Mule. --- fixed bad definition of xemacs-color-device in ps-print.el. - (for 19.14.) --- fixed problems with command-line options -T, -wn, etc. not - working. (for 19.14.) --- Options sub-menu provided under Mule for setting the current - language environment. --- fixed some problems with nested GCPRO's, that could have lead to - weird crashes. (for 19.14.) --- Things should *finally* work OK on the Alpha machines. - (Hopefully? Please?) (for 19.14.) --- Tooltalk warning is now a real warning (class `tooltalk'), so - you can suppress it. --- selections should work again. (for 19.14.) --- syntax tables work under Mule. - - NOTE: Syntax tables are *NOT* vectors any more but are their own - abstract `char-table' type. As such, some (broken) code is going - to break. (Typical error: "wrong type argument: sequencep, - #".) I've already had to patch cc-mode, - font-lock, mail-abbrevs, and symbol-syntax, and edebug, mim-syntax, - and paren still need to be changed. This is an unavoidable result - of RMS non-abstracted brokenness. Yuck Yuck Yuck Yuck! --- syntax table lookup should be faster (at least under non-Mule). - This could be a big win for scan-lists etc., and thus for cc-mode. --- fixed version of set-text-properties. (for 19.14.) --- fixes to display-warning-buffer to avoid problems when the - warning buffer is deleted. (for 19.14.) --- If a font can't be instantiated, you should now only get one - warning instead of a trillion of them. --- new Common-Lisp function `subseq', a generalization of `substring'. - -to 20.0 beta2 - --- new functions `function-min-args' and `function-max-args' for - determining the number of allowed arguments in a function - (of any sort accepted by funcall). (possibly for 19.14.) --- no more crashes under Mule if it can't find an acceptable font; - you just get a warning instead and a '~' character. --- new variable `disable-auto-save-when-buffer-shrinks', providing - you with a way to turn off this widely-hated behavior. (for 19.14.) --- new Common Lisp function `reduce'. --- I added some defines that should eliminate zillions of - "warning, incompatible pointer type" warnings for the memset(), - memcpy(), memcmp() functions in SunOS 4.x. (for 19.14.) --- composite characters are partially working under Mule. They are - correctly handled internally, but are not yet displayed properly: - you just get the familiar '~'. --- processes should now correctly do flushing of long PTY lines, - which they never did since the Lstream process rewrite sometime - during the 19.12 beta cycle. --- processes should be working better under Mule (at least there - will be no loss of data, which was a possibility before). More - work still to come in the area of handling encoding/decoding. --- fixes to font-lock that should make it go *much* faster (esp. in - lazy-lock) when moving backwards or jumping to an arbitrary point - in the buffer. Files like emacsfns.h are still problematic but - should be better than before. (for 19.14.) - -to 20.0 beta1 - --- ediff 2.44 --- hyperbole 3.19.08 --- oobr 2.9.9 --- I_SETSIG failed messages under Solaris should be gone --- add-submenu bug that affected func-menu fixed --- edebug no longer chokes on condition-cases --- redisplay under Mule should be significantly faster --- redisplay problem with overlay-arrows fixed --- range tables now print readably, using the new - Common-Lisp-compatible #s() syntax (this is the - generalized structure syntax). It would be possible - to make other unreadable Lisp objects be readable - using a similar format. I am not sure which objects - are good candidates, though -- suggestions? - -to 19.14 beta2 - --- w3 2.2.17 --- mailcrypt 3.4 is now the default --- new version of icomplete.el from David Hughes --- characters are now their own separate Lisp object type; this is - The Way It Should Have Always Been. This change is necessary for - byte-code portability under Mule and follows the Common Lisp model - of not needlessly confounding separate types, as is (unfortunately) - the fashion under E-Lisp. Characters print as characters using the - evil yucky GNU Emacs character syntax (e.g. ?a) rather than as - integers; this is the essence of the byte-code portability. In - deference to existing E-Lisp code, the following concessions are made: - - -- characters are represented directly; `eq' works on them. - (Yuck! This may be a problem if I ever want to add additional - information to characters.) - -- the comparison functions (<, =, etc) and arithmetic functions - (+, -, etc) accept characters and silently convert them to - integers. (This is semi-hateful but necessary for compatibility.) - -- functions that properly accept characters (e.g. char-to-string) - also accept integers and silently convert them to characters. - - I have provided new character primitives `char<', `char=', etc. - that are the proper way of comparing characters. --- The function `eq' has been infected with a heretofore-unknown virus - known as the "char-int confoundance disease". The CDC has been - warned, but in this case the cure (require that all existing .elc - files in the whole world be re-byte-compiled) is a lot worse than - the disease. Their recommendation is to use the new function - `really-eq' if you really need to distinguish between chars and ints. - Be warned, however, that this will run slower in byte-compiled code - because there is no opcode for `really-eq'. --- Similar infections have happened to `equal' (with a corresponding - `really-equal') and to the functions `memq', `delq', `assq', - `rassq', `remassq', `remrassq' and corresponding `equal' - equivalents. The functions `puthash' and `put-range-table' have - not been affected, however, because I don't think there will be much - of a compatibility problem here. --- BETA TESTERS LISTEN UP: The above changes have the potential of - causing weird lossage in existing packages. Therefore, PLEASE - PLEASE do the following for as many different packages as you can: - (1) try it out to make sure there's no obviously strange behavior - (a good example would be the error - "wrong type argument: integerp, ?B") or not-so-obviously - strange behavior, like prefix arguments not working - (yes, this did happen). - (2) re-byte-compile all the files in the package - (3) repeat step #1. Look especially hard this time because - the errors are more likely to occur this time. --- typecheck error-checking has been added for integers and for chars. - You may hit some aborts. --- XEmacs/Mule now performs automatic detection, encoding, and decoding - of files upon input and output. (Although the detection system definitely - has room for improvement.) --- XEmacs/Mule is still untested w.r.t. subprocesses and TTY support and - thus is likely to fail with both. --- XEmacs/Mule now byte-compiles files properly. (Well, it appears to ... - extensive testing has not yet been done.) - WARNING WARNING WARNING: - (a) You cannot compile files with extended characters in them - (e.g. lisp/mule/japanese-hooks.el) using a version of XEmacs - not compiled with Mule. - (b) If you compile such a file using XEmacs/Mule and attempt to - load it into a version of XEmacs not compiled with Mule, - you will get extremely random and undesirable results even - if you don't get a read error. The reason for this is that - a special encoding is used to allow arbitrary binary characters - to co-exist with the control characters used to change - the encoding state. Normal E-Lisp files compiled under - XEmacs/Mule should work under a non-Mule XEmacs because the - special encoding will not be used in this case. - At some point I would like to remove these gotchas but this will - require adding some smarts to the non-Mule XEmacs to be able to - at least partially handle the special encodings used. --- Here is a cool test of XEmacs/Mule: type 'C-h T' (capital T) and - you can get an Emacs tutorial in the language of your choice - (currently limited to Japanese, Korean, and Thai). Astute - testers will notice that the Thai one doesn't work yet; that - requires support for composite characters, which doesn't currently - exist. --- a change has been made to the handling of markers that should - eliminate those 15-second GC pauses that some of you may have - been seeing while processing the output of M-x grep, etc. - -to 19.14 beta1 - --- w3 2.2.16 --- mailcrypt 3.4beta --- preliminary Mule support is provided. This will get better over the - next month or so. All of the basics except for input method support - are there, although it's still somewhat slow and some of the parts - may not fit together perfectly. - - Here's a demonstration you can do when Mule support is enabled: - - -- load the file etc/mule/TUTORIAL.jp - -- evaluate (decode-coding-region 1 (point-max) 'ctext) - - In order for this to work, you have to have the proper Japanese - fonts installed (see below), or XEmacs will abort. (This will be fixed.) - - Soon, the decoding will happen automatically upon loading. - - Note also: IT MIGHT NOT CURRENTLY WORK TO BYTE-COMPILE FILES UNDER - XEmacs/Mule. You may get bogus results. Therefore, for the time - being do *not* do `make all-elc' using the built XEmacs/Mule. - This should be fixed by beta2, along with the rest of the file- - handling stuff. - - Note finally: You may get read errors trying to byte-compile the - Mule files under the non-Mule Xemacs. I have not yet come up with - a general solution to this problem. (I'm not convinced such a - solution even exists; byte-compiling could cause arbitrary code - to be executed, which will surely fail if the code uses Mule- - specific features.) --- We now may have the world's largest collection of FTP-able - international X11 fonts. Look in cs.uiuc.edu:/pub/xemacs/beta/fonts. - See the README file for directions on installing the fonts. There - is also the potential for generating loads and loads more of these - fonts, by converting MetaFont fonts. --- It is now possible to build simultaneously in the source directories - and in a separate build location, provided you have GNU make and - supply the `--with-gnu-make' option to configure. --- Support for bit vectors is now provided. Bit vectors are like regular - vectors except that the only allowed values for elements are 0 and 1, - and they are stored internally using bit fields instead of arrays - of 32-bit values, making them much less heavyweight. New primitives - for working with bit vectors are `bit-vector', `make-bit-vector', - `bit-vector-p', and `bvconcat' (equivalents of `vector', `make-vector', - `vectorp' and `vconcat'). All other vector primitives should work - fine with bit vectors. --- new specifier functions `specifier-matching-instance', - `specifier-matching-instance-from-inst-list', and - `valid-specifier-matchspec-p', for working with fonts in XEmacs/Mule. - These same functions could be used to provide much more flexible - handling of display tables and the like, and this work may get done - if there is demand for it. --- The handling of PURESIZE has been fixed up. There is no longer - special stuff needed in m/alpha.h. Alpha users may need to tweak - with puresize.h. --- You can now build statically on Linux. Doing this will allow you - to get proper backtraces. (Shared libraries are typically built - -fomit-frame-pointer, which screws everything up.) --- I have removed almost all of the MAC_* stuff and replaced it with - inline functions. configure attempts to detect whether your compiler - supports `inline'. However, if your compiler does support it - but is not GCC, you should look at how I've done things and see - if it meshes with your compiler. Basically, GCC has a nice feature - where you can declare a function `extern inline' and stick it in - a header file. This will cause the inline declaration to be - used if the function can be inlined, and an external reference to - be generated otherwise. Then, you define the function just - `inline' in one single file (inline.c). This is superior to the - method of declaring all inline functions as `static inline', which - could leave a separate copy of each function in lots of source - files. However, I'm not sure if non-GCC compilers support this. - Please read your compiler's documentation and fix up the definition - of INLINE in config.h.in accordingly. - - Also, there may be functions that would really benefit from inlining, - which you can sometimes specify as an option to your compiler. - We will have Quantify information on this. --- XEmacs now uses the v19 regex routines instead of the v18 regex - routines. Speed should not be significantly different due to the - non-Posix-backtracking default. If you want the full Posix - backtracking, use the functions `posix-looking-at', `posix-string-match', - etc. (Be warned that this may be significantly slower.) Note also - that the fishy problems may be forever banished. - - NOTE: The v19 regex routines do reallocs using rel-alloc if it is - available; God only knows why. If you notice some weird hiccups in - the regex routines, this is a likely culprit. Someone might want to - try putting '#undef REL_ALLOC' at the top of regex.c or something. - RMS also claims that much of the stuff that's going on here (recording - backtracking points) is only necessary for full Posix backtracking, - and thus we should be able to disable it in the normal (non-Posix) - case. --- XEmacs now caches compiled regexps. This may speed up regex searching. --- `replace-match' now takes a fourth argument STRING that allows for - replacement in a string instead of a buffer. --- new functions `upcase-initials' and `upcase-initials-region' from - FSF Emacs 19.29. --- match data is automatically saved and restored while a process filter - or sentinel is running. --- new type "char-table". A char table is for indexing characters and - is intended to be an extension/generalization of syntax tables, - display tables, case tables, category tables (a new kind of beast - allowing classifications of characters into categories for regexp - lookup, useful esp. for Mule), etc. You can set values for - an entire charset and for individual rows of a charset. Adding - and looking up values occurs in constant time. --- new type "range-table". A range table efficiently indexes ranges of - integers to values. --- new modeline spec '%C'; displays a mnemonic string for the - file-coding-system, under Mule. --- new function `device-on-window-system-p'; clean way of determining - whether mouse, glyph, etc. support is likely to be available on this - device. - #### We really need individual feature-test functions. --- new dialog-box functions `get-dialog-box-response' (like the misnamed - `x-popup-dialog' FSFmacs function), `message-box' (like the FSFmacs - function), and `message-or-box' (like the FSFmacs function). +to 20.1 beta1 +-- New symbol `signal-error-on-buffer-boundary'. Set to nil to avoid + lossage of zmacs region when moving against buffer boundaries. +-- python-mode.el-2.89 Courtesy of Barry Warsaw +-- added mouse-[123] and down-mouse-[123] Emacs-compatible keysyms +-- Clicking on `**' buffer modified status in mode-line now works the same + way as C-x C-q. +-- Miscellanous bug fixes from a number of people +-- mine.el-1.17 Courtesy of Jacques Duthen [New] +-- fast-lock.el-3.10.2 Courtesy of Simon Marshall +-- browse-cltl2.el-1.1 Courtesy of Holger Schauer [New] +-- eldoc.el-1.8 Courtesy of Noah Friedman [New] +-- webjump.el-1.4 Courtesy of Neil W. Van Dyke [New] +-- mime-setup is no longer dumped on SunPro/MULE. +-- Canna coredump fixed +-- verilog-mode.el Courtesy of Michael McNamara & Adrian Aichner [New] +-- overlay.el Courtesy of Joseph Nuspl [New] +-- hm--html-menus-5.1 Courtesy of Heiko Muenkel +-- tm-7.105 Courtesy of MORIOKA Tomohiko +-- Initial port of edmacro.el courtesy of Hrvoje Niksic [New] +-- Native sound support for FreeBSD Courtesy Dick van den Burg +-- Correct detection of GIF89, and implement detection of PNG +-- efs-1.15 courtesy of Andy Norman and Michael Sperber [New] +-- Easy customization of toolbar support courtesy of Hrvoje Niksic +-- balloon-help-1.03 courtesy of Kyle Jones [New] +-- 'compatible byte compiler warning type added and turned off by default +-- redo.el-1.00 courtesy of Kyle Jones [New] +-- floating-toolbar.el courtesy of Kyle Jones [New] +-- Initial Wnn/egg support and bug fixes courtesy of Jareth Hein [New] +-- Gnus-5.4.12 Courtesy of Lars Magne Ingebrigtsen [Upgrade] +-- custom-1.39 Courtesy of Per Abrahamsen [New] +-- W3-3.0.59 Courtesy of William Perry +-- VM-6.13 Courtesy of Kyle Jones [Upgrade] diff -r 498bf5da1c90 -r 0d2f883870bc ChangeLog --- a/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,17 @@ +Sat Feb 15 14:11:03 1997 Steven L Baur + + * XEmacs 20.1-b1 is released. + * XEmacs 19.15-b94 is released. + +Fri Feb 14 23:23:03 1997 Steven L Baur + + * README: ``This directory tree holds version 19.13 ...'' ??? + +Sun Feb 9 16:15:55 1997 Steven L Baur + + * XEmacs 19.15-b93 is released. + XEmacs 20.0 is released to the 'net. + Fri Feb 7 19:21:34 1997 Steven L Baur * XEmacs 20.0try3 is released. diff -r 498bf5da1c90 -r 0d2f883870bc README --- a/README Mon Aug 13 09:12:43 2007 +0200 +++ b/README Mon Aug 13 09:13:56 2007 +0200 @@ -1,4 +1,4 @@ -This directory tree holds version 19.13 of XEmacs, the extensible, +This directory tree holds version 20.0 of XEmacs, the extensible, customizable, self-documenting real-time display editor. See the file `etc/NEWS' for information on new features and other diff -r 498bf5da1c90 -r 0d2f883870bc configure --- a/configure Mon Aug 13 09:12:43 2007 +0200 +++ b/configure Mon Aug 13 09:13:56 2007 +0200 @@ -100,7 +100,7 @@ native_sound_lib='' # make normal error-checking be the default in alpha and beta versions, so # that bugs get noticed. Change this for released versions. -error_check_default='no' +error_check_default='yes' error_check_extents=$error_check_default error_check_typecheck=$error_check_default error_check_bufpos=$error_check_default @@ -273,11 +273,13 @@ the Motif XmIm* routines (when available). If the XmIm* routines are autodetected, then the default is --with-xim=motif, else --with-xim=no. ---with-canna Compile with support for Canna (an input method +--with-canna Compile with support for Canna (a Japanese input method + used in conjunction with Mule support). +--with-wnn Compile with support for WNN (a multi-language input method used in conjunction with Mule support). ---with-wnn Compile with support for WNN (an input method - used in conjunction with Mule support). - This doesn't work yet. + This is beta level code. +--with-wnn6 Compile with support for WNN version 6 + This is alpha level code. --with-i18n3 Compile with I18N level 3 (support for message translation). This doesn't currently work. @@ -409,6 +411,7 @@ with_mule | \ with_canna | \ with_wnn | \ + with_wnn6 | \ with_mocklisp | \ with_energize | \ with_sparcworks | \ @@ -4417,11 +4420,14 @@ \${ac_eA}XIM_MOTIF\${ac_eB}XIM_MOTIF\${ac_eC}1\${ac_eD} " } - + fi + # wnn6 implies wnn support + if test "$with_wnn6" = "yes" ; then + with_wnn=yes fi else # Other internationalization features depend on Mule with_mule="no" - for feature in xim canna wnn ; do + for feature in xim canna wnn wnn6 ; do if eval "test -n \"\$with_$feature\" -a \"\$with_$feature\" != no" ; then echo "configure: warning: --with-$feature ignored: Not valid without Mule support" >&2 fi @@ -6515,6 +6521,18 @@ " } +test "${with_wnn6}" = yes && +{ +test -n "$verbose" && \ +echo " defining WNN6" +echo "#define" WNN6 "1" >> confdefs.h +DEFS="$DEFS -DWNN6=1" +ac_sed_defs="${ac_sed_defs}\${ac_dA}WNN6\${ac_dB}WNN6\${ac_dC}1\${ac_dD} +\${ac_uA}WNN6\${ac_uB}WNN6\${ac_uC}1\${ac_uD} +\${ac_eA}WNN6\${ac_eB}WNN6\${ac_eC}1\${ac_eD} +" +} + test "${with_mock}" = yes && { test -n "$verbose" && \ @@ -6947,7 +6965,8 @@ test "$with_xim" = motif && echo " Using Motif to provide XIM support." test "$with_xim" = xlib && echo " Using raw Xlib to provide XIM support." test "$with_canna" = yes && echo " Compiling in support for Canna on Mule." -test "$with_wnn" = yes && echo " Compiling in support for WNN on Mule (doesn't currently work)." +test "$with_wnn" = yes && echo " Compiling in support for WNN on Mule." +test "$with_wnn6" = yes && echo " WNN support for version 6." test "$with_i18n3" = yes && echo " Compiling in I18N support, level 3 (doesn't currently work)." test "$with_cde" = yes && echo " Compiling in support for CDE." diff -r 498bf5da1c90 -r 0d2f883870bc configure.in --- a/configure.in Mon Aug 13 09:12:43 2007 +0200 +++ b/configure.in Mon Aug 13 09:13:56 2007 +0200 @@ -116,7 +116,7 @@ native_sound_lib='' # make normal error-checking be the default in alpha and beta versions, so # that bugs get noticed. Change this for released versions. -error_check_default='no' +error_check_default='yes' error_check_extents=$error_check_default error_check_typecheck=$error_check_default error_check_bufpos=$error_check_default @@ -289,11 +289,13 @@ the Motif XmIm* routines (when available). If the XmIm* routines are autodetected, then the default is --with-xim=motif, else --with-xim=no. ---with-canna Compile with support for Canna (an input method +--with-canna Compile with support for Canna (a Japanese input method + used in conjunction with Mule support). +--with-wnn Compile with support for WNN (a multi-language input method used in conjunction with Mule support). ---with-wnn Compile with support for WNN (an input method - used in conjunction with Mule support). - This doesn't work yet. + This is beta level code. +--with-wnn6 Compile with support for WNN version 6 + This is alpha level code. --with-i18n3 Compile with I18N level 3 (support for message translation). This doesn't currently work. @@ -425,6 +427,7 @@ with_mule | \ with_canna | \ with_wnn | \ + with_wnn6 | \ with_mocklisp | \ with_energize | \ with_sparcworks | \ @@ -2635,9 +2638,13 @@ test "$with_xim" = "xlib" && AC_DEFINE(XIM_XLIB) test "$with_xim" = "motif" && AC_DEFINE(XIM_MOTIF) fi + # wnn6 implies wnn support + if test "$with_wnn6" = "yes" ; then + with_wnn=yes + fi else # Other internationalization features depend on Mule with_mule="no" - for feature in xim canna wnn ; do + for feature in xim canna wnn wnn6 ; do if eval "test -n \"\$with_$feature\" -a \"\$with_$feature\" != no" ; then AC_WARN(--with-$feature ignored: Not valid without Mule support) fi @@ -3055,6 +3062,7 @@ IF_YES_AC_DEFINE(with_mule, MULE) IF_YES_AC_DEFINE(with_canna, HAVE_CANNA) IF_YES_AC_DEFINE(with_wnn, HAVE_WNN) +IF_YES_AC_DEFINE(with_wnn6, WNN6) IF_YES_AC_DEFINE(with_mock, MOCKLISP_SUPPORT) IF_YES_AC_DEFINE(with_sparcworks,SUNPRO) IF_YES_AC_DEFINE(usage_tracking, USAGE_TRACKING) @@ -3160,7 +3168,8 @@ test "$with_xim" = motif && echo " Using Motif to provide XIM support." test "$with_xim" = xlib && echo " Using raw Xlib to provide XIM support." test "$with_canna" = yes && echo " Compiling in support for Canna on Mule." -test "$with_wnn" = yes && echo " Compiling in support for WNN on Mule (doesn't currently work)." +test "$with_wnn" = yes && echo " Compiling in support for WNN on Mule." +test "$with_wnn6" = yes && echo " WNN support for version 6." test "$with_i18n3" = yes && echo " Compiling in I18N support, level 3 (doesn't currently work)." test "$with_cde" = yes && echo " Compiling in support for CDE." diff -r 498bf5da1c90 -r 0d2f883870bc etc/custom/check0.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/check0.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,17 @@ +/* XPM */ +static char * check0_xpm[] = { +"11 11 3 1", +" c #E6E6E6E6E6E6", +". c #737373737373", +"X c #BFBFBFBFBFBF", +" ", +" .", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" .........", +" .........."}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/custom/check1.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/check1.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,17 @@ +/* XPM */ +static char * check1_xpm[] = { +"11 11 3 1", +" c #737373737373", +". c #E6E6E6E6E6E6", +"X c #22228B8B2222", +" ", +" .", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" .........", +" .........."}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/custom/radio0.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/radio0.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,18 @@ +/* XPM */ +static char * radio0_xpm[] = { +"12 11 4 1", +" c #FFFFFFFFFFFF s background", +". c #E6E6E6E6E6E6", +"X c #BFBFBFBFBFBF", +"o c #737373737373", +" .. ", +" .... ", +" ..XX.. ", +" ..XXXX.. ", +" ..XXXXXX.. ", +"ooXXXXXXXXoo", +" ooXXXXXXoo ", +" ooXXXXoo ", +" ooXXoo ", +" oooo ", +" oo "}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/custom/radio1.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/radio1.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,18 @@ +/* XPM */ +static char * radio1_xpm[] = { +"12 11 4 1", +" c #FFFFFFFFFFFF s background", +". c #737373737373", +"X c #22228B8B2222", +"o c #E6E6E6E6E6E6", +" .. ", +" .... ", +" ..XX.. ", +" ..XXXX.. ", +" ..XXXXXX.. ", +"ooXXXXXXXXoo", +" ooXXXXXXoo ", +" ooXXXXoo ", +" ooXXoo ", +" oooo ", +" oo "}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus-tut.txt --- a/etc/gnus-tut.txt Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus-tut.txt Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-catchup-current-up.xbm --- a/etc/gnus/gnus-group-catchup-current-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-catchup-current-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x80,0x00,0x20,0xaa,0x2a,0xaa,0x0a,0x00,0x40,0x00,0x50,0x55,0x15,0x55, - 0x05,0x00,0x5e,0x00,0xa8,0xaa,0x35,0xaa,0x7a,0x00,0xb3,0x00,0xcc,0xaa,0x2a, - 0xa9,0xa6,0xfe,0x17,0x04,0x98,0x01,0x4c,0xf9,0x6f,0x3d,0xf8,0x05,0xb0,0x22, - 0x80,0xf7,0x20,0x2b,0xfc,0xaf,0x60,0x11,0x12,0x8a,0x20,0x1a,0x4a,0x6e,0xa8, - 0x08,0x83,0x42,0x28,0xfa,0x29,0x28,0xc8,0x04,0x03,0xe5,0xf7,0x06,0x29,0x10, - 0xcc,0x1a,0x81,0x3a,0x24,0x31,0x56,0x6a,0x4c,0x58,0xea,0xc7,0x58,0x64,0x76, - 0x60,0xa9,0x57,0x66,0x90,0x19,0xc8,0xf4,0x5f,0xa9,0xa6,0x6f,0xa5,0x52,0x4a, - 0x6a,0x4a,0xbe,0x29,0x29,0x29,0x7f,0x52,0xa5,0x52,0x55,0x49,0x52,0x29,0x49, - 0xaa,0x24,0x45,0x52,0x25,0x55,0xaa,0x4a}; + 0x20,0x40,0x10,0x20,0x0a,0x15,0x85,0x0a,0x20,0x20,0x28,0x50,0x8a,0x8a,0x02, + 0x05,0x10,0x5e,0x54,0xa8,0xa5,0x35,0x01,0x7a,0x00,0x33,0x54,0x95,0xaa,0xaa, + 0x02,0xcc,0xfe,0x17,0xa8,0xd8,0x01,0xac,0xfa,0x4f,0x3d,0xf8,0x05,0x30,0x22, + 0x80,0xf6,0x60,0x2b,0xfc,0x8f,0x20,0x11,0x82,0xca,0x60,0x1a,0x2a,0x6e,0x28, + 0x08,0x85,0x42,0x68,0xfa,0x11,0x28,0xc8,0x04,0x8b,0xe2,0xb7,0x06,0x21,0x14, + 0xd4,0x1a,0x11,0x31,0x04,0x31,0x56,0x6d,0xdc,0x58,0xea,0xc7,0x28,0x64,0x66, + 0x60,0xa9,0x57,0x72,0x90,0x49,0xc8,0xec,0x5f,0x99,0xa6,0x7f,0x95,0x52,0xaa, + 0x64,0x22,0xbf,0x49,0x2a,0xa9,0x7e,0x92,0x52,0x55,0x55,0x54,0x49,0x4a,0xa4, + 0x49,0xaa,0xa4,0x4a,0x2a,0x49,0x2a,0x25}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-catchup-current.xbm --- a/etc/gnus/gnus-group-catchup-current.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-catchup-current.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x21,0x42,0x00,0x55,0x88,0x10,0x55,0x80,0x22,0x4a,0x00,0x2a,0x10,0x01, - 0x54,0x40,0x5f,0x54,0x81,0x14,0x35,0x02,0x7c,0x42,0xb3,0xa8,0xd4,0x28,0x2a, - 0x04,0xad,0xfe,0x57,0x51,0xa8,0x01,0x1c,0xfa,0x5f,0x3d,0xf8,0x05,0xb0,0x23, - 0x80,0xf7,0x20,0x36,0xfc,0x8b,0xa0,0x11,0x02,0xde,0x20,0x12,0xaa,0x46,0x68, - 0x08,0x05,0x50,0x28,0xfa,0x51,0x25,0xc8,0x04,0x0b,0xe0,0xf7,0x06,0xa1,0x1a, - 0xd4,0x1a,0x15,0x30,0x04,0x31,0xd2,0x6a,0xac,0x58,0xea,0xc7,0x58,0x64,0x76, - 0x60,0x29,0x57,0x66,0x90,0x99,0xa8,0xf4,0x5f,0x29,0xa6,0x6f,0xa5,0xb2,0x4a, - 0xb5,0x14,0x3f,0xa2,0x48,0xaa,0xfe,0x2a,0x95,0x52,0x12,0x55,0xa5,0x24,0xa9, - 0x48,0x2a,0x55,0x25,0x26,0x49,0x89,0x94}; + 0x84,0x20,0x00,0x04,0x21,0x88,0x54,0x51,0x84,0x22,0x02,0x04,0x51,0x88,0xa0, + 0x42,0x04,0x1f,0x0a,0x28,0x51,0x75,0xa1,0x7a,0x04,0x23,0x04,0xcc,0xa1,0x76, + 0xa9,0xa6,0xfe,0x1b,0x00,0xd8,0x01,0x0c,0xfd,0x5f,0x3d,0xf8,0x05,0x30,0x26, + 0x80,0xf7,0x60,0x33,0xfc,0xdb,0x20,0x11,0x22,0x8e,0x20,0x14,0x8a,0x66,0x68, + 0x09,0x45,0x48,0x28,0xfc,0x11,0x21,0xc8,0x04,0x45,0xf4,0xf7,0x06,0x89,0x10, + 0xc4,0x1a,0x23,0x35,0x2c,0x31,0xaa,0x6c,0x54,0x58,0xea,0xc7,0x48,0x64,0x66, + 0xa0,0x99,0x57,0x72,0x50,0x59,0xc8,0xec,0x2f,0x49,0xa6,0x7f,0xaa,0x52,0xaa, + 0x64,0x49,0xbf,0x49,0x2a,0xa5,0x7e,0x92,0xa4,0x14,0x55,0xa9,0x52,0xaa,0x92, + 0x4a,0xa5,0x24,0x25,0xa5,0x94,0xaa,0xa8}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-describe-group-up.xbm --- a/etc/gnus/gnus-group-describe-group-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-describe-group-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x55,0xb3,0x59,0xb5,0x2a,0x29,0x95,0x4a,0x52,0xa5,0x24,0x29,0x95,0x54,0x52, - 0x90,0x59,0x93,0x15,0x41,0xa5,0x54,0x0a,0x00,0x4a,0x55,0x01,0x00,0x24,0x49, - 0x02,0x00,0x5b,0xb5,0x11,0x11,0xa2,0x12,0x00,0x00,0x94,0xaa,0x00,0x00,0x55, - 0x49,0x00,0x00,0x95,0x35,0x11,0x11,0x52,0x92,0x00,0x00,0xaa,0x54,0x00,0x00, - 0x49,0x4a,0x00,0x00,0xb5,0xb5,0x11,0x11,0x12,0x49,0x00,0x00,0xaa,0x92,0x00, - 0x00,0xa5,0xaf,0x02,0x00,0x59,0x58,0x11,0x11,0xb5,0x95,0x0a,0x00,0x12,0x72, - 0x12,0x40,0xf4,0xbb,0x0a,0x40,0xbb,0xb4,0xb5,0xb5,0xd9,0x7f,0x52,0x2a,0xae, - 0x9a,0x94,0xa4,0xf6,0x5d,0xa5,0x52,0xf7,0x57,0x55,0x95,0xfd,0xaa,0x2a,0x55, - 0x3e,0x25,0xa9,0x52,0xbf,0x92,0x24,0x29}; + 0x55,0xb5,0x55,0xb5,0xaa,0x12,0xa9,0x12,0x12,0x55,0x12,0x65,0xa9,0xa4,0x4a, + 0x10,0x55,0x9b,0x15,0xc1,0x55,0x51,0x09,0x00,0x92,0x4a,0x02,0x00,0xa9,0x24, + 0x01,0x00,0x55,0x5b,0x11,0x11,0x92,0xa4,0x00,0x00,0x2a,0x49,0x00,0x00,0x49, + 0x55,0x00,0x00,0x35,0x55,0x11,0x11,0xaa,0xaa,0x00,0x00,0x92,0x44,0x00,0x00, + 0xa5,0x32,0x00,0x00,0x55,0x55,0x11,0x11,0x29,0x55,0x01,0x00,0xaa,0x24,0x01, + 0x00,0x92,0x97,0x00,0x00,0x75,0xba,0x13,0x11,0x2a,0x51,0x04,0x00,0xb2,0xaa, + 0x0a,0x40,0x59,0x75,0x25,0x40,0xb5,0x3d,0x59,0xb5,0xfa,0x77,0xa5,0x2a,0xae, + 0x9a,0x2a,0x49,0xd6,0x5f,0x49,0xa5,0xf7,0x57,0x35,0x55,0x7d,0x29,0x95,0x2a, + 0x7e,0x55,0xa9,0x54,0x5f,0x92,0x94,0x92}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-exit-up.xbm --- a/etc/gnus/gnus-group-exit-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-exit-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -6,7 +6,7 @@ 0x07,0x00,0x00,0xde,0x1d,0x00,0xe0,0xfd,0x77,0x00,0xb0,0x6a,0xf3,0x00,0x20, 0x9c,0xa5,0x03,0x00,0xaa,0x86,0x02,0x00,0x65,0x06,0x02,0xab,0x6f,0xaf,0x59, 0x80,0x62,0x0c,0x00,0xaa,0xab,0xba,0x4a,0x40,0x21,0x10,0x10,0xea,0x45,0x4a, - 0x42,0x40,0x09,0x91,0x28,0xd2,0x51,0x04,0x82,0xa4,0x04,0x41,0x20,0xf0,0x12, - 0x14,0x85,0xa4,0x40,0x40,0x20,0xe2,0x0a,0x85,0x80,0xbc,0x43,0x00,0x2a,0xee, - 0x9d,0x5b,0x80,0xed,0x76,0x04,0x28,0x5b,0xa9,0xb3,0x01,0xff,0xff,0x85,0x48, - 0x00,0x86,0x91,0x02,0x4a,0x00,0x2a,0x50}; + 0x42,0x40,0x89,0x90,0x28,0xd2,0x21,0x02,0x82,0xa4,0x8a,0x44,0x20,0xf0,0x10, + 0x10,0x85,0xa4,0x04,0x4a,0x20,0xe2,0x22,0x80,0x80,0xbc,0x4b,0x09,0x2a,0xee, + 0x8e,0x32,0x80,0xeb,0x73,0x85,0x28,0x56,0xaa,0xb5,0x02,0xff,0xff,0x85,0x48, + 0x08,0x94,0x11,0x01,0x42,0x02,0x48,0x54}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-get-new-news-this-group-up.xbm --- a/etc/gnus/gnus-group-get-new-news-this-group-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-get-new-news-this-group-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x10,0x20,0x21,0x04,0xfe,0x0f,0x0a,0x51,0x02,0xa4,0x50,0x84,0x03,0x14,0x04, - 0x21,0x02,0x44,0xf1,0x84,0x02,0x2c,0xba,0x29,0x02,0x9e,0x4c,0x43,0x03,0x26, - 0x54,0x16,0x02,0x7c,0x25,0x43,0x02,0xdc,0x9a,0x11,0x02,0x94,0xb1,0xa2,0x03, - 0x64,0xfe,0x0f,0x02,0xcc,0x0a,0x29,0xfe,0x57,0x55,0x4d,0x22,0xc2,0xa4,0x14, - 0x88,0x10,0x2b,0x5b,0x22,0x42,0x52,0x16,0x88,0x94,0x2a,0x5b,0x22,0x00,0xa6, - 0x92,0x10,0x55,0x2b,0x3b,0x42,0x00,0xa6,0x96,0x28,0x55,0x53,0x36,0x82,0x00, - 0xfe,0x9f,0x28,0x54,0xab,0x08,0x82,0x80,0xa5,0x2f,0x50,0x2a,0x53,0x49,0x02, - 0x81,0xa5,0x17,0x54,0x28,0x73,0x46,0x80,0x02,0x55,0x0d,0x2a,0x50,0xdf,0x57, - 0x40,0x85,0xae,0x03,0x15,0x20,0x8a,0x52}; + 0x20,0x00,0x40,0x88,0xff,0x57,0x15,0x22,0x02,0x0c,0xa0,0x88,0x02,0xa4,0x0a, + 0x22,0x02,0x04,0xf0,0x84,0x03,0x54,0xdd,0x21,0x02,0x1e,0x14,0x97,0x02,0x66, + 0xcd,0x02,0x02,0x7c,0x14,0x2b,0x03,0x9c,0xad,0x41,0x02,0x54,0xb1,0x0a,0x02, + 0x2c,0xff,0x47,0x02,0xe4,0x14,0x2d,0xff,0x4f,0xa5,0x0a,0x48,0xa0,0x4a,0xb4, + 0x12,0x0a,0x51,0x1b,0x40,0xa1,0x96,0x36,0x2a,0x10,0x4a,0x56,0x80,0x4a,0x57, + 0x1b,0x55,0x00,0x92,0x52,0x00,0x55,0x26,0x17,0xa9,0x00,0xab,0x5a,0x04,0x2a, + 0xfe,0x1f,0x41,0x41,0xcb,0x48,0x14,0x14,0x95,0x2f,0x82,0x42,0x53,0x09,0x28, + 0x08,0xa5,0xaf,0x84,0xa2,0x75,0x06,0x12,0x04,0xd3,0x54,0x40,0x51,0xdf,0x0f, + 0x0a,0x82,0xae,0x23,0xa0,0x28,0x8a,0x4a}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-get-new-news-up.xbm --- a/etc/gnus/gnus-group-get-new-news-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-get-new-news-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x10,0x20,0x02,0x22,0xff,0x8b,0xa0,0x08,0x01,0x26,0x0a,0x51,0x01,0x0a,0x51, - 0x04,0x01,0xa2,0x7c,0x51,0x01,0x12,0xc4,0x08,0x01,0x4f,0x9b,0xa5,0x01,0x1b, - 0x46,0x01,0x01,0x6e,0x5a,0x2b,0x01,0x6e,0xa5,0x40,0x01,0xaa,0x6c,0x05,0x01, - 0x96,0xdf,0x53,0x01,0x72,0xaa,0x06,0xff,0x27,0x25,0x55,0x08,0xd0,0x54,0x8a, - 0x42,0x85,0x25,0x2d,0x14,0x28,0xfd,0xfd,0x81,0x02,0x07,0x8b,0x54,0x54,0x85, - 0x8c,0x02,0x01,0x87,0x85,0x28,0x54,0x45,0x85,0x84,0x02,0xc7,0x82,0x12,0x28, - 0xe7,0x82,0x40,0x85,0x15,0x81,0x0a,0xd0,0xe6,0x81,0xa0,0x8a,0x3d,0xff,0x0a, - 0xa0,0xf4,0x02,0xa0,0x8a,0x5a,0x57,0x0a,0xd0,0xaa,0x82,0x40,0x85,0xef,0x2b, - 0x0a,0x28,0x55,0x81,0xa0,0x42,0xc7,0x2b}; + 0x00,0x81,0x00,0x08,0xff,0x2b,0xa8,0x42,0x01,0x42,0x05,0x14,0x01,0x16,0x50, + 0x41,0x01,0xa2,0x7a,0x0a,0x01,0x0a,0xcc,0x40,0x01,0xaf,0x92,0x15,0x01,0x13, + 0x56,0x43,0x01,0xbe,0x2a,0x09,0x01,0x6e,0xcc,0x52,0x01,0xca,0x69,0x80,0x01, + 0x32,0xdf,0x2b,0x01,0x66,0x55,0x85,0xff,0x33,0xa9,0x2e,0x24,0xc9,0x92,0x88, + 0x09,0x82,0x4a,0x2e,0xa0,0x28,0xfd,0xf9,0x14,0x42,0x07,0x8d,0x42,0x08,0x85, + 0x8d,0x20,0x52,0x87,0x85,0x8a,0x80,0x45,0x86,0x20,0x2a,0xc7,0x82,0x8a,0x00, + 0xe7,0x82,0x41,0xd4,0x15,0x81,0x14,0x81,0xe6,0x81,0x81,0xa8,0x3d,0xff,0x14, + 0x82,0xfa,0x02,0x42,0xd1,0x52,0x57,0x08,0x8a,0xad,0x82,0xa2,0xa0,0xef,0x2b, + 0x04,0x05,0x55,0x81,0x51,0x50,0xc7,0x2b}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-kill-group-up.xbm --- a/etc/gnus/gnus-group-kill-group-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-group-kill-group-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x20,0x00,0x10,0xaa,0x0a,0x55,0x45,0x00,0x50,0x00,0x08,0x55,0x05,0xaa, - 0x42,0xc0,0xff,0x3f,0x14,0x54,0x00,0x60,0x41,0x42,0x00,0xa0,0x14,0x68,0xc0, - 0x21,0x43,0x42,0xe0,0xe3,0x0b,0x50,0xb0,0x06,0x42,0x42,0xf0,0x07,0x2a,0x68, - 0x70,0x07,0x06,0x42,0xe0,0x03,0x52,0x68,0x40,0x01,0x06,0x42,0x40,0x01,0x52, - 0x50,0xc8,0x05,0x06,0x62,0x0c,0x0c,0x52,0x48,0x30,0x03,0x06,0x62,0xc0,0x00, - 0x52,0x48,0xc0,0x00,0x06,0x62,0x30,0x03,0x52,0x48,0x0c,0x0c,0x02,0x42,0x08, - 0x04,0xaa,0x50,0x00,0x00,0x06,0x4a,0x00,0x00,0x52,0x50,0x00,0x00,0x06,0x42, - 0x00,0x00,0x52,0x68,0x00,0x00,0x06,0xc2,0xff,0xff,0x53,0x24,0x11,0x00,0x00, - 0x10,0x44,0x55,0x55,0x45,0x91,0x00,0x00}; + 0x00,0x04,0x20,0x20,0x54,0xa1,0x0a,0x4a,0x02,0x0a,0x50,0x01,0xa0,0x40,0x05, + 0x54,0xca,0xff,0x7f,0x00,0x50,0x00,0x60,0x55,0x42,0x00,0xa0,0x80,0x68,0xc0, + 0x21,0x2b,0x42,0xe0,0xe3,0x83,0x50,0xb0,0x06,0x2a,0x4a,0xf0,0x07,0x42,0x60, + 0x70,0x07,0x16,0x42,0xe0,0x03,0x42,0x68,0x40,0x01,0x2a,0x42,0x40,0x01,0x82, + 0x50,0xc8,0x05,0x2a,0x4a,0x0c,0x0c,0x82,0x60,0x30,0x03,0x2a,0x4a,0xc0,0x00, + 0x82,0x40,0xc0,0x00,0x2a,0x6a,0x30,0x03,0x42,0x41,0x0c,0x0c,0x16,0x54,0x08, + 0x04,0x22,0x41,0x00,0x00,0x4a,0x54,0x00,0x00,0x02,0x41,0x00,0x00,0x56,0x54, + 0x00,0x00,0x02,0x42,0x00,0x00,0x52,0xe8,0xff,0xff,0x0b,0x04,0x84,0x00,0x42, + 0x52,0x11,0xaa,0x28,0x00,0xa4,0x04,0x04}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-subscribe-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-group-subscribe-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,12 @@ +#define noname_width 32 +#define noname_height 32 +static char noname_bits[] = { + 0x08,0x04,0x00,0x40,0x22,0x51,0x55,0x15,0x88,0x04,0x00,0x20,0x22,0xa0,0xaa, + 0x4a,0xc4,0xff,0x3f,0x00,0x61,0x80,0x60,0x55,0x54,0x8a,0xa0,0x80,0x42,0x84, + 0x20,0x2b,0x68,0x8a,0xe0,0x83,0x42,0x80,0x00,0x2a,0xd4,0xff,0x00,0x42,0x41, + 0x80,0x00,0x16,0x54,0x8a,0x00,0x42,0x41,0x84,0x00,0x2a,0x54,0x8a,0x00,0x82, + 0x41,0x80,0x00,0x2a,0xd4,0xff,0x00,0x82,0x42,0x80,0x00,0x2a,0x68,0x8a,0x00, + 0x82,0x44,0x84,0x00,0x2a,0x52,0x8a,0x00,0x42,0x40,0x80,0x00,0x16,0xea,0xff, + 0x00,0x22,0x40,0x80,0x00,0x4a,0x4a,0x80,0x00,0x02,0x61,0x80,0x00,0x56,0x44, + 0x80,0x00,0x02,0x51,0x80,0x00,0x52,0xc4,0xff,0xff,0x0b,0xa1,0x04,0x00,0x42, + 0x14,0xa8,0xaa,0x88,0x82,0x02,0x00,0x22}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-subscribe-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-group-subscribe-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,38 @@ +/* XPM */ +static char * icon-unsubscribe_xpm[] = { +"32 32 3 1", +" c #BFBFBFBFBFBF s backgroundToolBarColor", +". c #000000000000", +"X c #FFFFFFFFFFFF", +" ", +" ", +" ", +" ", +" ................ ", +" .XXXXXXXX.XXXXX.. ", +" .XX.X.XXX.XXXXX.X. ", +" .XXX.XXXX.XXXXX.XX. ", +" .XX.X.XXX.XXXXX..... ", +" .XXXXXXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXX.XXXX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXX.XXXX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .................... ", +" ", +" ", +" "}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-unsubscribe-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-group-unsubscribe-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,12 @@ +#define noname_width 32 +#define noname_height 32 +static char noname_bits[] = { + 0x08,0x04,0x00,0x40,0x22,0x51,0x55,0x15,0x88,0x04,0x00,0x20,0x22,0xa0,0xaa, + 0x4a,0xc4,0xff,0x3f,0x00,0x61,0x80,0x60,0x55,0x54,0xa0,0xa0,0x80,0x42,0x90, + 0x20,0x2b,0x68,0x8a,0xe0,0x83,0x42,0x84,0x00,0x2a,0xd4,0xff,0x00,0x42,0x41, + 0x80,0x00,0x16,0x54,0xa0,0x00,0x42,0x41,0x90,0x00,0x2a,0x54,0x8a,0x00,0x82, + 0x41,0x84,0x00,0x2a,0xd4,0xff,0x00,0x82,0x42,0x80,0x00,0x2a,0x68,0xa0,0x00, + 0x82,0x44,0x90,0x00,0x2a,0x52,0x8a,0x00,0x42,0x40,0x84,0x00,0x16,0xea,0xff, + 0x00,0x22,0x40,0x80,0x00,0x4a,0x4a,0x80,0x00,0x02,0x61,0x80,0x00,0x56,0x44, + 0x80,0x00,0x02,0x51,0x80,0x00,0x52,0xc4,0xff,0xff,0x0b,0xa1,0x04,0x00,0x42, + 0x14,0xa8,0xaa,0x88,0x82,0x02,0x00,0x22}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-group-unsubscribe-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-group-unsubscribe-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,38 @@ +/* XPM */ +static char * icon-subscribe_xpm[] = { +"32 32 3 1", +" c #BFBFBFBFBFBF s backgroundToolBarColor", +". c #000000000000", +"X c #FFFFFFFFFFFF", +" ", +" ", +" ", +" ", +" ................ ", +" .XXXXXXXX.XXXXX.. ", +" .XXXXXX.X.XXXXX.X. ", +" .XXXXX.XX.XXXXX.XX. ", +" .XX.X.XXX.XXXXX..... ", +" .XXX.XXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXX.X.XXXXXXXXX. ", +" .XXXXX.XX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXX.XXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXX.X.XXXXXXXXX. ", +" .XXXXX.XX.XXXXXXXXX. ", +" .XX.X.XXX.XXXXXXXXX. ", +" .XXX.XXXX.XXXXXXXXX. ", +" ..........XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .XXXXXXXX.XXXXXXXXX. ", +" .................... ", +" ", +" ", +" "}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-pointer.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-pointer.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,6 @@ +#define noname_width 18 +#define noname_height 13 +static char noname_bits[] = { + 0x00,0x00,0x00,0xc0,0x0c,0x00,0xe0,0x1f,0x00,0x92,0x39,0x00,0x0e,0x71,0x02, + 0x46,0xe0,0x03,0x20,0xc0,0x01,0x00,0x08,0x00,0x10,0x0d,0x00,0xc4,0x08,0x00, + 0x78,0x08,0x00,0x18,0x89,0x00,0x00,0x08,0x00}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-caesar-message-up.xbm --- a/etc/gnus/gnus-summary-caesar-message-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-caesar-message-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x04,0x11,0x04,0x01,0x51,0x44,0x51,0x50,0x04,0x11,0x84,0x0a,0x41,0x84,0x22, - 0x40,0xd4,0xff,0xbf,0x0a,0x41,0x00,0x60,0x50,0x54,0xe6,0xb8,0x01,0x42,0x29, - 0x25,0x55,0x68,0xa9,0xe4,0x83,0x44,0x2f,0x05,0x2a,0x52,0xe9,0x38,0x82,0x40, - 0x00,0x00,0x2a,0x6a,0x82,0x10,0x42,0x40,0x00,0x00,0x16,0x4a,0xcb,0x1c,0x22, - 0x61,0x2b,0x25,0x4a,0x44,0x2d,0x1d,0x02,0x51,0x2d,0x05,0x56,0x44,0xc9,0x04, - 0x02,0x61,0x00,0x00,0x52,0x54,0x18,0x00,0x0a,0x41,0x3c,0x00,0x42,0x54,0xe6, - 0x3f,0x16,0x42,0xe6,0x3f,0x42,0x68,0x3c,0x2a,0x0a,0x42,0x18,0x2a,0x52,0x54, - 0x00,0x08,0x06,0x41,0x00,0x00,0x42,0xd4,0xff,0xff,0x2b,0x41,0x04,0x41,0x04, - 0x24,0x51,0x14,0x51,0x09,0x08,0x82,0x08}; + 0x40,0x40,0x10,0x01,0x15,0x15,0x45,0x50,0x40,0x40,0x08,0x05,0x14,0x14,0xa2, + 0x50,0xe2,0xff,0x3f,0x82,0x48,0x00,0xe0,0x28,0x62,0xe6,0xb8,0x82,0x48,0x29, + 0x25,0x29,0x62,0xa9,0xe4,0x83,0x48,0x2f,0x05,0x2a,0x42,0xe9,0x38,0x42,0x60, + 0x00,0x00,0x16,0x4a,0x82,0x10,0x22,0x50,0x00,0x00,0x4a,0x42,0xcb,0x1c,0x02, + 0x68,0x2b,0x25,0x56,0x42,0x2d,0x1d,0x02,0x50,0x2d,0x05,0x52,0x4a,0xc9,0x04, + 0x0a,0x40,0x00,0x00,0x42,0x6a,0x18,0x00,0x16,0x41,0x3c,0x00,0x42,0x54,0xe6, + 0x3f,0x0a,0x41,0xe6,0x3f,0x52,0x54,0x3c,0x2a,0x06,0x42,0x18,0x2a,0x42,0x68, + 0x00,0x08,0x2a,0x44,0x00,0x00,0x06,0xd2,0xff,0xff,0x53,0x20,0x84,0x20,0x04, + 0x8a,0x10,0x8a,0xa8,0x20,0x4a,0x21,0x02}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-cancel-article-up.xbm --- a/etc/gnus/gnus-summary-cancel-article-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-cancel-article-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x19,0x11,0x09,0x11,0xa2,0x54,0x45,0x4a,0x08,0x02,0x90,0x20,0x82,0x50,0x25, - 0x0a,0x39,0x13,0x8f,0xb1,0x82,0xc8,0x29,0x08,0x48,0x62,0x98,0x22,0x12,0x18, - 0x56,0x48,0x51,0x07,0x17,0x13,0x14,0x01,0xa3,0x50,0x42,0x81,0x60,0x02,0x10, - 0x03,0x42,0x54,0x53,0x06,0x78,0x11,0x90,0x08,0xae,0x4a,0x0a,0xfa,0x01,0x10, - 0xa0,0xa4,0x52,0x45,0x13,0x51,0x19,0x11,0x48,0x15,0x82,0x54,0x22,0x20,0x29, - 0x82,0x08,0x4a,0x80,0x28,0xb5,0x11,0x5b,0x91,0x01,0x54,0x01,0x2a,0x54,0x01, - 0x54,0x80,0x01,0xa4,0x02,0x2a,0xb5,0x11,0xb9,0x91,0x08,0x54,0x02,0x24,0xa2, - 0x80,0xa8,0x88,0x08,0x2a,0x04,0x22,0x35,0x91,0xb1,0x99,0x81,0x2a,0x0a,0x02, - 0x14,0x40,0x50,0x28,0x41,0x15,0x05,0x42}; + 0x11,0x11,0x01,0x11,0x54,0x4a,0xa9,0x52,0x82,0x10,0x04,0x08,0x28,0x24,0xa1, + 0x42,0x91,0x91,0x0f,0x19,0x25,0xaa,0xa9,0x44,0x88,0x60,0x18,0x11,0x42,0x1c, + 0x56,0x44,0x19,0x07,0x97,0x31,0x44,0x01,0x23,0x0a,0x12,0x81,0x60,0x50,0x80, + 0x02,0x42,0x05,0x3b,0x05,0x78,0x59,0x00,0x0a,0x56,0x12,0xaa,0xf4,0x05,0x41, + 0x00,0x54,0x51,0x10,0x5b,0x51,0x95,0x55,0x10,0x15,0x00,0x11,0x42,0x40,0x55, + 0x44,0x10,0x2a,0x00,0x21,0x5b,0x91,0x5b,0x95,0x80,0x24,0x00,0x21,0x12,0x92, + 0x2a,0x14,0x44,0x01,0x80,0x42,0x11,0xb5,0x35,0x19,0x54,0x11,0x08,0x42,0x02, + 0x44,0xa1,0x08,0xa8,0x22,0x14,0x52,0x11,0x99,0x51,0x11,0x4a,0x22,0x14,0x4a, + 0x20,0x89,0x42,0x10,0x15,0x40,0x20,0x45}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-catchup-and-exit-up.xbm --- a/etc/gnus/gnus-summary-catchup-and-exit-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-catchup-and-exit-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x04,0x41,0x04,0x01,0x51,0x14,0x41,0x54,0x84,0x20,0x2a,0x01,0x21,0x8a,0x00, - 0x54,0x84,0x10,0x55,0x80,0x51,0x44,0x80,0x2a,0x04,0x11,0x15,0x80,0x51,0xa4, - 0x9f,0x2a,0x84,0x98,0x50,0x40,0x21,0xd6,0x10,0x14,0x44,0x73,0xf0,0x21,0xd1, - 0x60,0x90,0x4b,0xc4,0x60,0x08,0x03,0xa1,0xf0,0x0f,0x55,0x94,0x11,0xfc,0x81, - 0x82,0x11,0x8c,0x2a,0xa8,0x12,0x84,0x80,0x84,0x13,0x84,0x2a,0x52,0x17,0x74, - 0x41,0x80,0xfa,0x4f,0x14,0x2a,0x92,0x64,0x20,0x49,0x9f,0xbc,0x96,0x92,0xf6, - 0x67,0xa9,0x55,0x95,0x34,0x4a,0x4a,0x96,0x56,0x29,0x24,0xfd,0x5f,0x95,0xa9, - 0xde,0x3c,0x29,0x2a,0x9d,0x9d,0x92,0x52,0xfe,0x5f,0xaa,0x25,0xf9,0x4f,0x49, - 0x54,0xa5,0x52,0x92,0x4a,0x52,0x29,0x55}; + 0x08,0x81,0x00,0x04,0x42,0x28,0x52,0x51,0x14,0x85,0x08,0x04,0x81,0x20,0x42, + 0x49,0x14,0x8a,0x08,0x20,0x41,0x21,0x52,0x15,0x14,0x44,0x00,0x40,0x41,0x91, + 0xbf,0x2a,0x14,0xda,0x10,0x80,0x81,0x94,0x90,0x2a,0x14,0x73,0xf0,0x80,0xe1, + 0x60,0x90,0x2b,0xc4,0x60,0x08,0x43,0xa2,0xf0,0x0f,0x15,0x88,0x11,0xfc,0x21, + 0xd2,0x11,0x8c,0x4a,0x80,0x12,0x84,0x00,0xd5,0x13,0x84,0x55,0x00,0x17,0x74, + 0x80,0x54,0xfb,0xcf,0x2a,0x02,0x9a,0x24,0x40,0x54,0x9f,0xbc,0x36,0xa9,0xf4, + 0x77,0x49,0x94,0x96,0x94,0xa4,0x25,0x95,0x35,0x15,0xa9,0xfe,0xbf,0xa4,0x92, + 0xdc,0x5c,0x29,0x4a,0x9e,0x3d,0x95,0xaa,0xfe,0x4f,0x52,0x24,0xf9,0xaf,0x4a, + 0xa9,0x52,0x91,0x94,0x25,0x29,0x55,0x52}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-catchup-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-summary-catchup-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,12 @@ +#define noname_width 32 +#define noname_height 32 +static char noname_bits[] = { + 0x11,0x91,0x11,0x95,0x54,0x25,0x54,0x21,0x02,0x90,0x00,0x84,0xa0,0x0a,0x54, + 0x29,0x1b,0xb1,0x11,0x91,0x40,0x0a,0x4a,0x25,0x8a,0xa0,0x20,0x88,0x20,0x14, + 0x0e,0x22,0x9b,0x51,0xb7,0x99,0x20,0x14,0x0b,0x02,0x42,0xc1,0x22,0x28,0x14, + 0x92,0x48,0x45,0x51,0x19,0x11,0x11,0x14,0x42,0xaa,0x54,0x42,0x88,0x00,0x02, + 0x90,0x72,0xaa,0x56,0x15,0x71,0x11,0x17,0x42,0x3a,0x49,0x4b,0x28,0x49,0xa4, + 0x22,0x04,0x30,0x02,0x09,0xb1,0xdb,0x59,0xb5,0x15,0xa0,0xd3,0xff,0x40,0x05, + 0xbf,0x02,0x2a,0xd3,0x08,0x54,0x91,0x53,0x77,0x7f,0xc8,0xa9,0xd4,0x8a,0x62, + 0x22,0x86,0x35,0xc8,0x5b,0x4b,0x67,0x93,0xfd,0x91,0x39,0x24,0x18,0xff,0x7a, + 0x90,0x46,0xc5,0xcf,0x25,0x94,0x21,0xf1}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-catchup-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/gnus/gnus-summary-catchup-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,37 @@ +/* XPM */ +static char * icon-catchup2_xpm[] = { +"32 32 2 1", +" c #000000000000", +". c #BFBFBFBFBFBF s backgroundToolBarColor", +" ... ... ... ... ... ... ... ...", +"................................", +"................................", +"................................", +" ... ... ... ... ... ... ... ...", +"................................", +"................................", +"................. .............", +" ... ... ... ... . ... ... ...", +"................ ..............", +"............... ................", +"................................", +" ... ... ... ... ... ... ... ...", +"................................", +"................................", +"............. .......... .....", +" ... ... ... . ... ... . ...", +"............ .......... ......", +"........... ........... ........", +"............ .......... .......", +" ... ... ... . . ... ... ... ...", +"............... ..... ", +"................ ... ......", +"........ ..... ... ...... .....", +" ... .. .. . . . . .. . .", +"....... .... .... ... .. . ... ", +"...... ...... ... ..... ... ...", +"...... .. .... ...... .. ..", +" ... ... . ... .. .. ..", +"........... .... . .... .", +".......... ..... ..... .. .", +".......... ..... ....... ... "}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-exit-up.xbm --- a/etc/gnus/gnus-summary-exit-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-exit-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x11,0x99,0x19,0x51,0xa4,0x22,0x82,0x14,0x02,0x88,0x28,0x42,0xa8,0x22,0x82, - 0x10,0x11,0xf8,0xff,0x53,0x95,0x17,0xfe,0x11,0x40,0x41,0xf9,0x45,0x14,0x2b, - 0xf0,0x23,0x51,0x95,0xf2,0x99,0x15,0x21,0xf9,0x23,0x40,0x84,0xf4,0x89,0x2a, - 0x23,0xf1,0x21,0x91,0x15,0xf4,0x95,0x24,0x53,0xf7,0x23,0x92,0x05,0xf7,0x89, - 0x00,0xa3,0xfe,0x23,0x5b,0x15,0xf0,0x19,0x10,0x4b,0xf5,0x41,0x42,0x21,0xf0, - 0x0b,0x28,0x0a,0xfb,0x41,0x91,0xb0,0xf0,0x35,0x4a,0x0b,0xf4,0x09,0x20,0xa7, - 0x5c,0xa3,0x8a,0xe1,0xeb,0x10,0xb1,0xfe,0x5d,0x53,0x0a,0x10,0x82,0x14,0xa0, - 0x42,0x28,0x40,0x14,0x14,0x85,0x2a,0x51,0x51,0x31,0x91,0x15,0x15,0x8a,0x24, - 0x40,0xa0,0x10,0x12,0x29,0x0a,0x84,0x40}; + 0x19,0x51,0x91,0x11,0x82,0x14,0x2a,0x48,0x28,0x42,0x40,0x25,0x82,0x10,0x15, + 0x00,0x59,0xfa,0xff,0x5b,0x12,0x4b,0xfe,0x21,0x40,0x21,0xf1,0x93,0x2a,0x0b, + 0xf8,0x05,0x91,0xb5,0xf2,0x31,0x24,0x01,0xf1,0x4b,0x12,0x54,0xfa,0x01,0x80, + 0x83,0xf0,0x55,0x5b,0x35,0xf2,0x11,0x00,0x8b,0xfe,0x4b,0x2a,0x21,0xf7,0x21, + 0x80,0x0b,0xf6,0x13,0x5b,0xb5,0xf4,0x59,0x10,0x03,0xf1,0x01,0x42,0x2b,0xf4, + 0x55,0x90,0x40,0xf3,0x03,0x13,0x1a,0xf8,0x59,0xa8,0x83,0xf2,0x11,0x02,0x2b, + 0x5c,0x43,0x50,0xe3,0xee,0x10,0x93,0xfc,0x55,0x5b,0x48,0x92,0x92,0x00,0x22, + 0x49,0x48,0xaa,0x08,0x00,0x84,0x00,0xb5,0xbb,0x31,0x5b,0x01,0x00,0x0a,0x00, + 0x54,0x25,0x51,0x55,0x01,0x48,0x04,0x00}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-followup-up.xbm --- a/etc/gnus/gnus-summary-followup-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-followup-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x41,0x08,0x02,0x6a,0x2a,0xa3,0x6a,0x22,0x21,0x2a,0x00,0x08,0x88,0x00, - 0x55,0xa2,0x22,0x5e,0x80,0x2a,0xea,0xa9,0x36,0x50,0x62,0x18,0x42,0x85,0x18, - 0xb6,0x28,0x08,0x06,0x17,0x82,0xe3,0x01,0xa3,0x32,0x74,0x80,0x20,0x42,0x41, - 0x00,0xc0,0x14,0x54,0x00,0x40,0xa0,0xa2,0x00,0x80,0x2b,0x4a,0xe1,0x80,0x44, - 0x90,0x9a,0x00,0x11,0x02,0x86,0x01,0x43,0xd2,0x61,0x01,0x32,0x62,0x70,0x01, - 0x4a,0x1c,0x30,0x02,0x04,0x04,0x08,0x02,0xac,0x07,0x00,0x02,0x28,0x04,0x00, - 0x04,0x4c,0x0a,0x00,0x08,0x13,0x08,0x00,0xc8,0x22,0x1b,0x00,0x70,0x6a,0x10, - 0x00,0x10,0x01,0x2a,0x00,0x60,0x54,0x20,0x00,0x20,0x01,0x6b,0x00,0x40,0x6a, - 0x44,0x00,0xc0,0x04,0xa1,0x00,0x80,0x51}; + 0x00,0x00,0x40,0x08,0xb6,0x76,0x37,0x63,0x20,0x02,0x00,0x04,0x8a,0x48,0x55, + 0x51,0x10,0x22,0x0e,0x82,0xa6,0xaa,0xa9,0x36,0x12,0x62,0x38,0x20,0xa0,0x18, + 0x96,0x4a,0x0a,0x07,0x17,0x00,0xa2,0x01,0xa3,0x76,0x6a,0x80,0x60,0x00,0x60, + 0x00,0x40,0x55,0x52,0x00,0x40,0x00,0xa6,0x00,0x80,0x6b,0x90,0xe1,0x80,0x04, + 0x24,0x9a,0x00,0x51,0x82,0x86,0x01,0x85,0xaa,0x61,0x01,0x32,0x60,0x70,0x01, + 0x42,0x1d,0x30,0x02,0x14,0x04,0x08,0x02,0x4c,0x06,0x00,0x02,0x28,0x06,0x00, + 0x04,0xac,0x08,0x00,0x08,0x0b,0x0a,0x00,0xc8,0x22,0x12,0x00,0x70,0x6a,0x1a, + 0x00,0x10,0x01,0x20,0x00,0x60,0x52,0x32,0x00,0x20,0x08,0x46,0x00,0x40,0x63, + 0x50,0x00,0x40,0x04,0x85,0x00,0x80,0x52}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-followup-with-original-up.xbm --- a/etc/gnus/gnus-summary-followup-with-original-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-followup-with-original-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x04,0x40,0x40,0x00,0x63,0x37,0x36,0x76,0x14,0x40,0x41,0x01,0x21,0x15,0x10, - 0x52,0x84,0xa0,0x4a,0x08,0x32,0x2a,0x22,0x63,0x42,0xa1,0x94,0x04,0x28,0x0a, - 0x26,0x50,0x82,0x50,0x87,0x82,0x32,0x26,0x6b,0x36,0x42,0xd1,0x22,0x20,0x28, - 0x84,0x88,0x4a,0x82,0x10,0x22,0x00,0x32,0xa6,0xaa,0x76,0xa2,0x68,0x00,0x00, - 0x08,0x9a,0x55,0x55,0xa2,0x86,0x00,0x00,0x92,0x71,0x75,0x6b,0x62,0xcc,0x02, - 0x04,0x1c,0xe3,0x52,0x51,0xc8,0xe0,0x0c,0x82,0x3b,0x90,0xa4,0x32,0x0c,0x00, - 0x19,0x4a,0x05,0x00,0x49,0x01,0x04,0x00,0x12,0x54,0x0a,0x00,0x52,0x23,0x0a, - 0x00,0x24,0x94,0x14,0x00,0x64,0x21,0x10,0x00,0x48,0x84,0x2b,0x00,0x48,0x33, - 0x24,0x00,0x90,0x44,0x51,0x00,0x90,0x11}; + 0x04,0x40,0x10,0x00,0xa3,0x36,0xa6,0x76,0x54,0x40,0x11,0x02,0x01,0x2a,0x88, + 0x48,0x54,0x81,0x22,0x22,0x22,0x6a,0xaa,0x2a,0x4a,0x02,0x21,0xa0,0x90,0x50, + 0x8e,0x0a,0x02,0x0a,0x27,0x50,0xb2,0xa2,0xab,0x26,0x42,0xaa,0x00,0x92,0x94, + 0x00,0xaa,0x20,0x00,0xaa,0x00,0x85,0xb6,0x22,0x76,0x32,0x20,0xea,0x80,0x44, + 0x8a,0x98,0x2a,0x11,0x10,0x87,0x00,0x44,0xa6,0x71,0x6b,0x33,0x60,0xcc,0x22, + 0x44,0x1d,0xe3,0x0a,0x11,0xc8,0xe0,0x24,0x44,0x3e,0x90,0x6c,0x2b,0x08,0x00, + 0x09,0xa0,0x06,0x00,0x49,0x0a,0x04,0x00,0x92,0x50,0x0b,0x00,0x32,0x26,0x0c, + 0x00,0xa4,0x90,0x11,0x00,0x24,0x24,0x14,0x00,0xc8,0x82,0x22,0x00,0x48,0x32, + 0x2a,0x00,0x90,0x42,0x50,0x00,0x90,0x28}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-copy-up.xbm --- a/etc/gnus/gnus-summary-mail-copy-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-copy-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x80,0x20,0x11,0x00,0x2a,0x4a,0x44,0x55,0xfe,0xff,0xff,0x07,0x0e,0x00,0x80, - 0x55,0x32,0x00,0x60,0x84,0xc2,0x00,0x18,0x2c,0x02,0x03,0x06,0x84,0x03,0x8c, - 0x01,0x24,0x02,0x74,0x02,0x94,0x02,0x03,0x0c,0x04,0x82,0x00,0x10,0x2c,0xf2, - 0xff,0xff,0x7f,0x52,0x00,0x00,0x2c,0x9b,0x01,0x00,0x23,0x16,0x06,0xc0,0xa0, - 0x1e,0x18,0x30,0x20,0x12,0x60,0x0c,0x60,0x14,0xa0,0x0b,0x20,0x10,0x10,0x30, - 0xa0,0x1a,0x0c,0x40,0x20,0x10,0x02,0x80,0x60,0x15,0x01,0x00,0x23,0xd0,0x00, - 0x00,0xa4,0x3a,0x00,0x00,0x38,0xf0,0xff,0xff,0x7f,0x94,0x00,0x00,0x08,0x02, - 0x55,0x55,0x21,0x50,0x00,0x00,0x4a,0x82,0xaa,0xaa,0x20,0x28,0x00,0x00,0x08, - 0x42,0x55,0x55,0xa5,0x10,0x00,0x00,0x00}; + 0x00,0x20,0x20,0x40,0xaa,0x8a,0x0a,0x15,0xfe,0xff,0xff,0x27,0x0e,0x00,0x80, + 0x4d,0x32,0x00,0x60,0x04,0xc2,0x00,0x18,0x54,0x02,0x03,0x06,0x04,0x03,0x8c, + 0x01,0x54,0x02,0x74,0x02,0x04,0x02,0x03,0x0c,0x54,0x82,0x00,0x10,0x84,0xf2, + 0xff,0xff,0x3f,0x52,0x00,0x00,0x6c,0x9b,0x01,0x00,0x23,0x16,0x06,0xc0,0x60, + 0x1e,0x18,0x30,0x20,0x14,0x60,0x0c,0xa0,0x11,0xa0,0x0b,0x20,0x14,0x10,0x30, + 0x60,0x11,0x0c,0x40,0x20,0x14,0x02,0x80,0xa0,0x12,0x01,0x00,0x23,0xd8,0x00, + 0x00,0x64,0x32,0x00,0x00,0x38,0xf8,0xff,0xff,0xbf,0x02,0x00,0x40,0x24,0x54, + 0x55,0x15,0x11,0x01,0x00,0x40,0x44,0x54,0x55,0x15,0x11,0x01,0x00,0x40,0x44, + 0x54,0x55,0x05,0x11,0x02,0x00,0x50,0x44}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-delete-up.xbm --- a/etc/gnus/gnus-summary-mail-delete-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-delete-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x04,0x10,0x82,0x40,0xa1,0x8a,0x28,0x14,0x14,0x20,0x42,0x42,0xf1,0x15,0x91, - 0x20,0x5c,0x43,0x04,0x95,0x8d,0x2e,0xf1,0x00,0x14,0x86,0x9c,0x5b,0x8e,0x2e, - 0xe6,0x0c,0x38,0x9f,0x1f,0x7a,0xf5,0xf1,0xa3,0xc9,0x48,0xb5,0x84,0x88,0xf2, - 0xf1,0xd3,0x08,0x18,0x9f,0x3f,0x09,0xae,0x2e,0xfe,0x08,0x14,0x95,0x0c,0x04, - 0x4e,0x06,0x04,0x04,0x18,0x57,0x03,0x06,0xfa,0x01,0xc1,0x01,0xa0,0xaa,0x38, - 0x00,0x14,0x40,0x07,0x80,0x42,0xf5,0x00,0x40,0x20,0xc0,0x00,0x20,0x8a,0x2a, - 0x03,0x60,0x41,0x00,0x05,0x10,0x14,0x55,0x1c,0xa8,0x82,0x00,0x61,0x0c,0x28, - 0x55,0xa4,0x25,0x45,0x00,0x09,0x4a,0x10,0x95,0xa0,0x00,0x8a,0x20,0x14,0x55, - 0x20,0x8a,0x40,0x80,0x14,0x21,0x2a,0x2a}; + 0x08,0x00,0x80,0x00,0xa2,0xaa,0x2a,0x54,0x08,0x00,0x40,0x81,0xf2,0xab,0x2a, + 0x28,0x5c,0x03,0x80,0x82,0x2d,0x56,0xf5,0x28,0x84,0x06,0x98,0x8b,0x5d,0x5e, + 0xe7,0x2c,0x1c,0x1f,0x1f,0xba,0xf1,0xf3,0xa7,0xc9,0x44,0xa8,0x90,0x88,0xf1, + 0xf3,0x8b,0x08,0x1c,0x5f,0x7f,0x09,0xad,0x1e,0xff,0x08,0x04,0x46,0x08,0x04, + 0xae,0x26,0x06,0x04,0x18,0x8b,0x02,0x06,0xfa,0x23,0xc1,0x01,0x20,0x88,0x38, + 0x00,0x95,0x62,0x07,0x80,0x40,0xe4,0x00,0x40,0x14,0xd1,0x00,0x20,0x42,0x44, + 0x03,0x60,0x10,0x11,0x05,0x10,0x4a,0x44,0x1c,0xa8,0x00,0x11,0x61,0x0c,0x2a, + 0x42,0xa4,0x25,0x81,0x14,0x09,0x42,0x14,0x20,0x50,0x15,0xa1,0x4a,0x05,0x40, + 0x04,0x00,0xa8,0x0a,0x51,0x55,0x05,0x50}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-forward-up.xbm --- a/etc/gnus/gnus-summary-mail-forward-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-forward-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x10,0x01,0x01,0x02,0x45,0x54,0xa8,0x50,0x38,0x81,0x02,0x85,0x66,0x28,0x50, - 0x20,0xcc,0x42,0x45,0x85,0x92,0x10,0xf0,0x28,0xc0,0x4b,0x3d,0x83,0xea,0x02, - 0x24,0x22,0x90,0x56,0x13,0x8e,0xda,0x0c,0x11,0x2c,0x70,0xa4,0x08,0x88,0x35, - 0x6d,0x08,0x30,0x50,0x14,0x08,0xa0,0x14,0x0b,0x04,0x20,0x42,0x04,0xfc,0x7f, - 0x10,0x03,0x02,0x60,0x22,0x01,0x03,0x18,0xc8,0xe0,0x01,0x44,0x22,0x3e,0x00, - 0x0a,0xf0,0x21,0x00,0x51,0x3a,0x20,0x80,0x02,0x10,0x10,0x40,0x54,0x22,0x10, - 0xb0,0x80,0x74,0x10,0x28,0x2a,0xc0,0x10,0x84,0x80,0xaa,0x10,0x2a,0x2a,0x40, - 0x11,0x41,0x40,0x15,0xca,0x14,0x15,0xa0,0xac,0x20,0x20,0x0a,0x3e,0x8a,0x4a, - 0x50,0x80,0x10,0x00,0x04,0x55,0x44,0x55}; + 0x10,0x42,0x80,0x20,0x84,0x10,0x2a,0x14,0x3a,0xa5,0x40,0x41,0x64,0x08,0x14, + 0x28,0xd6,0xa0,0x62,0x85,0x80,0x15,0xe8,0x20,0xca,0x41,0x39,0x8b,0xb0,0x2a, + 0x24,0x22,0xd2,0x86,0x12,0x86,0x58,0x24,0x11,0x2c,0xd2,0x8c,0x08,0x98,0x34, + 0x75,0x08,0x10,0x30,0x14,0x08,0x60,0x8a,0x0e,0x04,0x20,0x10,0x05,0xfc,0x7f, + 0x45,0x02,0x02,0x60,0x10,0x01,0x03,0x18,0xca,0xe0,0x01,0x44,0x20,0x3e,0x00, + 0x0a,0xf4,0x21,0x00,0x53,0x32,0x20,0x80,0x80,0x10,0x10,0x40,0x2a,0x2a,0x10, + 0xb0,0x80,0x60,0x10,0x28,0x2a,0xea,0x10,0x84,0x40,0x81,0x10,0x2a,0x14,0x94, + 0x11,0x41,0x21,0x21,0xca,0x2a,0x48,0x84,0xac,0x80,0x02,0x21,0x3d,0x54,0x50, + 0x14,0x84,0x00,0x05,0x42,0x21,0xaa,0x50}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-get-up.xbm --- a/etc/gnus/gnus-summary-mail-get-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-get-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x04,0x10,0x22,0x55,0x41,0x85,0x08,0x00,0x2a,0x28,0xa2,0xa9,0x80,0x82, - 0x10,0x04,0x15,0x14,0x45,0xc1,0x43,0x79,0x10,0x54,0x0c,0x44,0x45,0xa1,0x4a, - 0xab,0x20,0x14,0x58,0x85,0x87,0xb2,0xb2,0x21,0x2b,0x18,0xb0,0x01,0x81,0x22, - 0x08,0x82,0x2a,0x68,0x5c,0xc6,0x40,0x85,0x83,0x3a,0x15,0x50,0x0a,0x24,0x20, - 0xf4,0xff,0xff,0x7f,0x72,0x00,0x00,0x2c,0x90,0x01,0x00,0x23,0x1a,0x06,0xc0, - 0x60,0x10,0x18,0x30,0x20,0x12,0x60,0x0c,0xa0,0x18,0x90,0x0b,0x20,0x12,0x0c, - 0x30,0x60,0x10,0x02,0x40,0x20,0x1a,0x01,0x80,0xa0,0xd0,0x00,0x00,0x23,0x32, - 0x00,0x00,0x64,0x18,0x00,0x00,0x38,0xf2,0xff,0xff,0xbf,0x20,0x10,0x91,0x24, - 0x8a,0x42,0x44,0x90,0x41,0x14,0x11,0x05}; + 0x48,0x00,0x11,0x02,0x12,0x54,0x84,0x50,0x40,0x81,0x50,0x82,0x2a,0x28,0x0a, + 0x28,0x80,0x42,0xa0,0x82,0xaa,0x13,0x3d,0x28,0x40,0x46,0xd4,0x42,0xb5,0x28, + 0x86,0x10,0x50,0xda,0x51,0x47,0x99,0xb0,0x09,0x13,0x14,0x50,0x01,0x45,0x21, + 0x18,0x82,0x21,0x74,0x4c,0xc7,0x94,0x81,0x13,0x78,0x02,0x94,0x44,0x05,0x29, + 0xf1,0xff,0xff,0x7f,0x74,0x00,0x00,0x2c,0x91,0x01,0x00,0x23,0x14,0x06,0xc0, + 0xa0,0x11,0x18,0x30,0x20,0x14,0x60,0x0c,0x60,0x12,0x90,0x0b,0x20,0x18,0x0c, + 0x30,0xa0,0x12,0x02,0x40,0x20,0x18,0x01,0x80,0xa0,0xd2,0x00,0x00,0x23,0x38, + 0x00,0x00,0x64,0x12,0x00,0x00,0x38,0xf8,0xff,0xff,0xbf,0x02,0x00,0x00,0x20, + 0xa8,0xaa,0xaa,0x8a,0x05,0x00,0x40,0x20}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-originate-up.xbm --- a/etc/gnus/gnus-summary-mail-originate-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-originate-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x80,0x00,0x20,0x00,0x2a,0xa8,0x0a,0x55,0x40,0x85,0xff,0x0f,0x2a,0xa0,0x00, - 0x54,0x80,0x8a,0x00,0x24,0x55,0xc0,0x00,0x7c,0xf8,0xff,0x1f,0x20,0x2a,0x11, - 0x68,0x60,0xf8,0xff,0x1f,0x20,0x25,0x88,0x00,0x20,0x90,0xa2,0x00,0x60,0x04, - 0xc8,0xfc,0x21,0xfe,0xff,0x00,0xa0,0x1c,0x80,0x6c,0x21,0x66,0x80,0x00,0xa0, - 0x84,0x81,0x00,0x20,0x04,0x86,0x00,0x60,0x06,0x98,0x00,0x20,0x04,0xe4,0x00, - 0xa0,0x05,0x83,0x80,0x25,0x84,0x80,0x00,0x60,0x46,0x80,0x00,0x20,0x34,0x80, + 0x04,0x42,0x08,0x10,0xa1,0x10,0x42,0x05,0x14,0xa2,0xff,0xaf,0x01,0x89,0x00, + 0x14,0x54,0xa4,0x00,0x64,0x02,0xc1,0x00,0x3c,0xf8,0xff,0x1f,0xa0,0x6d,0x10, + 0x68,0x20,0xf8,0xff,0x1f,0x60,0x12,0x84,0x00,0x20,0x48,0xd1,0x00,0xa0,0x02, + 0x88,0xfc,0x21,0xfc,0xff,0x00,0x60,0x1e,0x80,0x6c,0x21,0x64,0x80,0x00,0xa0, + 0x86,0x81,0x00,0x20,0x04,0x86,0x00,0x60,0x05,0x98,0x00,0x20,0x04,0xe4,0x00, + 0xa0,0x06,0x83,0x80,0x25,0x84,0x80,0x00,0x60,0x46,0x80,0x00,0x20,0x34,0x80, 0x00,0xa0,0x0d,0x80,0xff,0x3f,0x04,0x00,0x00,0x2e,0xfe,0xff,0xff,0x4f,0x48, - 0x04,0x21,0x12,0x12,0x51,0x88,0x44,0x40,0x84,0x22,0x10,0x15,0x21,0x10,0x45, - 0x20,0x4a,0x45,0x08,0x8a,0x10,0x20,0x42}; + 0x92,0x44,0x12,0x92,0x08,0x11,0x44,0x00,0x21,0x44,0x11,0x55,0x48,0x21,0x44, + 0x80,0x02,0x8a,0x10,0x2a,0xa8,0x40,0x44}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-reply-up.xbm --- a/etc/gnus/gnus-summary-mail-reply-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-reply-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x80,0x00,0x20,0x00,0x2a,0x54,0x75,0x55,0x40,0x01,0x88,0x81,0x15,0xa8,0x06, - 0x2e,0xa0,0xc2,0x05,0x88,0x14,0x38,0x12,0x28,0x42,0x0d,0x11,0x84,0x10,0x03, - 0x09,0x2a,0xe2,0x80,0x04,0x42,0x28,0x40,0x04,0x17,0x9a,0x49,0x80,0x58,0x38, - 0x20,0x41,0x16,0xca,0x10,0xc1,0xb1,0x08,0x93,0x60,0x10,0x0a,0x1c,0x18,0x50, - 0x09,0x30,0x06,0x10,0x0c,0xc8,0x05,0xb0,0x09,0x06,0x18,0x10,0x0c,0x01,0x20, - 0x50,0x88,0x00,0x40,0x10,0x6a,0x00,0x80,0xb1,0x18,0x00,0x00,0x12,0x0a,0x00, - 0x00,0x5c,0xf8,0xff,0xff,0x1f,0x02,0x00,0x44,0x52,0x54,0x55,0x11,0x08,0x00, - 0x80,0x44,0xa1,0xaa,0x2a,0x20,0x14,0x00,0x90,0x8a,0x40,0x55,0x25,0x20,0x15, - 0x00,0x80,0x0a,0xa0,0x54,0x55,0xa0,0x0a}; + 0x00,0x40,0x40,0x20,0xaa,0x2a,0x7a,0x0a,0x00,0x80,0x88,0x51,0xaa,0x2a,0x06, + 0x06,0x00,0xc0,0x05,0x58,0xaa,0x3a,0x12,0x08,0x00,0x0c,0x11,0x2c,0xaa,0x03, + 0x09,0x42,0xc0,0x80,0x04,0x06,0x35,0x40,0x04,0x57,0x98,0x49,0x80,0x18,0x3a, + 0x20,0x41,0x56,0xc8,0x10,0xc1,0x11,0x0c,0x93,0x60,0x50,0x0a,0x1c,0x18,0x90, + 0x08,0x30,0x06,0x30,0x0a,0xc8,0x05,0x90,0x08,0x06,0x18,0x30,0x0a,0x01,0x20, + 0x10,0x88,0x00,0x40,0x50,0x6a,0x00,0x80,0x11,0x19,0x00,0x00,0x52,0x0c,0x00, + 0x00,0x1c,0xf9,0xff,0xff,0x5f,0x44,0x44,0x44,0x24,0x11,0x11,0x11,0x09,0x44, + 0x44,0x44,0xa0,0x11,0x11,0x11,0x15,0x44,0x44,0x44,0x40,0x11,0x11,0x91,0x14, + 0x44,0x44,0x04,0xa2,0x11,0x22,0xa2,0x08}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-mail-save-up.xbm --- a/etc/gnus/gnus-summary-mail-save-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-mail-save-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x08,0x00,0x02,0x80,0xa2,0xaa,0xa0,0x2a,0x08,0x00,0x15,0x80,0xc2,0xff,0xff, - 0x7f,0x94,0x03,0x00,0x70,0xa1,0x0c,0x00,0x4c,0x84,0x30,0x00,0xc3,0xd1,0xc0, - 0xc0,0x40,0x84,0x80,0x33,0x40,0xc8,0x60,0xcc,0x40,0xa2,0x10,0x00,0xc1,0x88, - 0x08,0x00,0x46,0xa2,0x06,0x00,0x58,0xfc,0xff,0x0f,0x60,0x36,0x00,0x0b,0xc0, - 0x2c,0x10,0xfd,0x7f,0x34,0x01,0x4b,0x12,0x2d,0x40,0x19,0x44,0x34,0x04,0x4b, - 0x11,0xad,0x00,0x2d,0x44,0x34,0x10,0x8b,0x10,0x2d,0x00,0x2d,0x45,0xf4,0xff, - 0x0b,0x08,0x4d,0xad,0xac,0x42,0x94,0x52,0x09,0x14,0xed,0xff,0x5d,0x41,0x74, - 0x2d,0x0b,0x0a,0xed,0x36,0xab,0x50,0xb4,0x35,0x0d,0x81,0xaa,0x3a,0x59,0x2a, - 0xf8,0xff,0x0f,0x80,0x42,0x00,0xa5,0x2a}; + 0x00,0x10,0x10,0x00,0x55,0x45,0x45,0x55,0x00,0x10,0x08,0x00,0xd4,0xff,0xff, + 0x7f,0x82,0x03,0x00,0xf0,0xd0,0x0c,0x00,0x4c,0x82,0x30,0x00,0x43,0xd4,0xc0, + 0xc0,0x40,0x80,0x80,0x33,0xc0,0xaa,0x60,0xcc,0x40,0xc0,0x10,0x00,0x41,0x95, + 0x08,0x00,0x46,0xc0,0x06,0x00,0xd8,0xfe,0xff,0x0f,0x60,0x2c,0x00,0x0b,0x40, + 0x35,0x10,0xfd,0x7f,0x2c,0x02,0x2b,0x49,0x35,0x40,0x4d,0x12,0xac,0x00,0x0b, + 0xa0,0x35,0x00,0xad,0x0a,0x2c,0x24,0x09,0x90,0x2d,0x00,0x5d,0x25,0xf4,0xff, + 0x0b,0x80,0xa6,0x55,0xad,0x2a,0x4c,0xaa,0x08,0x40,0xf5,0xff,0x5d,0x15,0x6c, + 0x35,0x0b,0x20,0x66,0x37,0xab,0x4a,0x6c,0x2d,0x0d,0x00,0xb9,0x35,0x4b,0x55, + 0xf4,0xff,0x1f,0x80,0x01,0x40,0x80,0x2a}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-next-unread-up.xbm --- a/etc/gnus/gnus-summary-next-unread-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-next-unread-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x80,0x80,0x10,0x10,0x36,0x36,0xa6,0x66,0x40,0xa1,0x10,0x02,0x2a,0x08,0xa4, - 0x50,0x80,0xa2,0x0e,0x05,0x36,0xaa,0x69,0x6a,0xa0,0x60,0x18,0x01,0x0a,0x1d, - 0x56,0x50,0x10,0x06,0x97,0x0a,0xe6,0x01,0x23,0x62,0x70,0x80,0x60,0x09,0x45, - 0x00,0x40,0x44,0x50,0x00,0x40,0x11,0xa6,0x00,0x80,0x66,0x48,0xe1,0x80,0x10, - 0x22,0x9a,0x00,0x45,0x84,0x86,0x01,0x13,0xa3,0x61,0x01,0x62,0x74,0x70,0x01, - 0x0a,0x18,0x30,0x02,0x44,0x06,0x08,0x02,0x0c,0x06,0x00,0x02,0x68,0x04,0x00, - 0x04,0x2c,0xca,0x07,0x7c,0x0b,0xa8,0x0a,0xd6,0xa4,0x36,0x19,0xa1,0x23,0x50, - 0x5a,0xab,0x95,0x35,0xb5,0x2b,0x21,0x70,0x19,0x49,0x83,0x6a,0x0a,0xe6,0x36, - 0xe2,0x07,0x7c,0x40,0x88,0x00,0x80,0x2a}; + 0x08,0x10,0x20,0x00,0xa3,0x66,0xab,0x76,0x14,0x11,0x04,0x02,0x41,0x04,0xa1, + 0x48,0x14,0x51,0x1e,0x22,0x62,0xa6,0xa9,0x2a,0x0a,0x71,0x18,0xa0,0x40,0x18, + 0xb6,0x0a,0x8a,0x06,0x17,0x50,0xb2,0x01,0x63,0x27,0x62,0x80,0x20,0x90,0x50, + 0x00,0x40,0x25,0x4a,0x00,0x40,0x80,0xe2,0x00,0x80,0x36,0x12,0xe1,0x80,0x41, + 0x84,0x9a,0x00,0x29,0x10,0x87,0x01,0x85,0xa6,0x61,0x01,0x32,0x62,0x70,0x01, + 0x42,0x18,0x30,0x02,0x14,0x06,0x08,0x02,0x4c,0x06,0x00,0x02,0x28,0x04,0x00, + 0x04,0xac,0xca,0x07,0x7c,0x0b,0x68,0x0d,0xea,0x20,0x1b,0x12,0x93,0x6b,0xb4, + 0x54,0x29,0x03,0x91,0xba,0x95,0x51,0x74,0x19,0x53,0x0b,0x6a,0x0a,0xd6,0x62, + 0xe0,0x07,0x7c,0x09,0x8a,0x00,0x80,0x42}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-post-news-up.xbm --- a/etc/gnus/gnus-summary-post-news-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-post-news-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x80,0x10,0x00,0x10,0x36,0x66,0x6b,0x67,0xa0,0x10,0x04,0x10,0x0a,0x05,0x51, - 0x45,0x10,0xa8,0x0e,0x10,0x66,0xa3,0xb9,0x66,0x12,0x6a,0x18,0x11,0x80,0x18, - 0x56,0x04,0x2a,0x06,0x17,0x51,0xa2,0x01,0x63,0x26,0x6a,0x80,0x20,0x51,0x60, - 0x00,0x40,0x04,0x52,0x00,0xc0,0x50,0xa6,0x00,0x80,0x26,0x90,0x00,0x80,0x48, - 0x85,0x01,0x00,0x13,0x50,0x01,0x00,0x41,0x2a,0x02,0x00,0x36,0xa2,0x02,0x00, - 0x42,0x08,0x04,0x00,0x14,0xa2,0x06,0x00,0xa4,0x2a,0x0a,0x00,0x28,0xa0,0x0c, - 0x00,0x9c,0x0a,0x11,0x80,0x23,0x10,0x14,0x40,0x8a,0x66,0x23,0xb0,0x22,0x12, - 0x34,0x4e,0x2a,0x00,0xc1,0x13,0x40,0xaa,0x14,0xa2,0x12,0x22,0xa2,0x2a,0x66, - 0x4a,0x25,0x22,0x01,0x10,0x88,0x48,0x50}; + 0x00,0x10,0x10,0x01,0x6b,0xa7,0x66,0x72,0x04,0x10,0x02,0x05,0xa1,0x8a,0x50, + 0x48,0x04,0x20,0x8f,0x20,0x72,0xab,0x39,0x2b,0x02,0x64,0x58,0xa4,0x50,0x19, + 0x16,0x01,0x0a,0x06,0x57,0x54,0xe2,0x01,0x23,0x23,0x72,0x80,0x20,0x94,0x44, + 0x00,0x40,0x01,0x50,0x00,0xc0,0x54,0xa6,0x00,0x80,0x22,0x92,0x00,0x80,0x4a, + 0x40,0x01,0x00,0x11,0x8a,0x01,0x00,0x45,0x32,0x02,0x00,0x2a,0x42,0x02,0x00, + 0xa2,0x10,0x05,0x00,0x0c,0x4a,0x06,0x00,0x24,0x22,0x0a,0x00,0x68,0xaa,0x0c, + 0x00,0x0c,0x00,0x11,0x80,0x53,0x2a,0x14,0x40,0x05,0x22,0x23,0x70,0x62,0x92, + 0x34,0x0e,0x09,0x24,0xc0,0x4b,0x52,0x80,0x0a,0x21,0x80,0x6b,0x62,0xaa,0x36, + 0x04,0x15,0x01,0x42,0x51,0x80,0xa8,0x28}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-prev-unread-up.xbm --- a/etc/gnus/gnus-summary-prev-unread-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-prev-unread-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x08,0x08,0x22,0x00,0x63,0xa3,0xaa,0x76,0x14,0x2a,0x00,0x02,0x81,0x80,0xaa, - 0x50,0x54,0x2a,0x0e,0x05,0x22,0xa2,0x69,0x62,0x4a,0x65,0x18,0x09,0x10,0x18, - 0x56,0x52,0x42,0x07,0x17,0x00,0xb2,0x01,0x63,0x77,0x62,0x80,0x20,0x00,0x54, - 0x00,0x40,0x55,0x40,0x00,0x40,0x00,0xb6,0x00,0x40,0x6b,0xa0,0xe1,0xc0,0x27, - 0x8a,0x9f,0xa0,0x0e,0x50,0x86,0x31,0xb9,0xe6,0x61,0x95,0x34,0x62,0x70,0xbb, - 0x9a,0x18,0x30,0x51,0x32,0x06,0x08,0xa2,0x8c,0x06,0x00,0xc2,0x37,0x04,0x00, - 0x84,0x42,0x0a,0x00,0xe4,0x14,0x08,0x00,0x18,0xa0,0x1b,0x00,0x50,0x2b,0x14, - 0x00,0x10,0x44,0x21,0x00,0x60,0x11,0x34,0x00,0x20,0x22,0x22,0x00,0xc0,0x6a, - 0x52,0x00,0x40,0x00,0x84,0x00,0x80,0x55}; + 0x08,0x08,0x40,0x20,0x23,0x63,0x2b,0x2b,0x54,0x14,0x24,0xa4,0x01,0x02,0x09, + 0x01,0x54,0xa9,0x2e,0x2a,0x22,0xa2,0xa9,0x62,0x4a,0x6a,0x18,0x12,0x90,0x18, + 0xb6,0x04,0x02,0x06,0x17,0x50,0xea,0x01,0x63,0x2b,0x64,0x80,0x20,0x44,0x51, + 0x00,0x40,0x21,0x44,0x00,0x40,0x8a,0xe2,0x00,0xc0,0x22,0x0a,0xe1,0xc0,0x2f, + 0xd0,0x9f,0x20,0x4d,0x42,0x87,0xb1,0x1a,0xea,0x61,0x15,0x72,0x60,0x70,0xbb, + 0x14,0x1d,0x30,0xb1,0x5a,0x04,0x08,0x22,0x0d,0x06,0x00,0xc2,0x6f,0x06,0x00, + 0x84,0x20,0x08,0x00,0x64,0x0a,0x0a,0x00,0x58,0x50,0x12,0x00,0x10,0x27,0x1a, + 0x00,0x50,0x90,0x20,0x00,0xa0,0x24,0x32,0x00,0x20,0x82,0x26,0x00,0xc0,0x32, + 0x40,0x00,0x40,0x44,0xaa,0x00,0x80,0x11}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-reply-up.xbm --- a/etc/gnus/gnus-summary-reply-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-reply-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x40,0x08,0x88,0x20,0x14,0xa2,0x22,0x0a,0x42,0x09,0x88,0x50,0x28,0x90,0x22, - 0x04,0x82,0x42,0x88,0x28,0x50,0x10,0x2a,0x42,0x02,0x45,0xb5,0x08,0xa8,0xf0, - 0x42,0x44,0x02,0x1a,0x81,0x13,0xa8,0x86,0x00,0x42,0x82,0x41,0x00,0x0b,0x70, - 0x40,0x80,0x57,0x1a,0x20,0x80,0x19,0xb4,0x1a,0xc0,0x6e,0x0e,0x08,0x60,0x31, - 0x74,0x08,0x70,0x6e,0x86,0x04,0x98,0x21,0x04,0x03,0x5c,0x60,0x04,0x0c,0x36, - 0x20,0x06,0x10,0x0f,0x60,0x05,0x70,0x07,0xa0,0x04,0xc8,0x09,0x60,0x05,0x04, - 0x10,0x20,0x06,0x02,0x20,0xa0,0x86,0x01,0xc0,0x60,0x45,0x00,0x00,0x21,0x24, - 0x00,0x00,0x62,0x1e,0x00,0x00,0xbc,0x0d,0x00,0x00,0x30,0xfc,0xff,0xff,0xbf, - 0x55,0x4a,0x92,0xaa,0x92,0x52,0x55,0x49}; + 0x10,0x00,0x11,0x88,0x45,0x55,0x84,0x22,0x08,0x80,0x10,0x88,0x42,0x55,0xa4, + 0x22,0x28,0x00,0x01,0x84,0x05,0x55,0x5a,0x21,0x50,0x00,0x35,0x8a,0x09,0xf5, + 0xc2,0x20,0x24,0x18,0x81,0x85,0x01,0x87,0x00,0x2a,0xd4,0x41,0x00,0x43,0x61, + 0x40,0x80,0x17,0x1c,0x20,0x80,0x58,0xb5,0x1a,0xc0,0x3f,0x0c,0x08,0x60,0xb0, + 0x75,0x08,0xb0,0x2e,0x84,0x04,0xb8,0xa1,0x06,0x03,0x4c,0x20,0x04,0x0c,0x36, + 0x60,0x06,0x10,0x0f,0x20,0x06,0x70,0x07,0x60,0x05,0xc8,0x09,0xa0,0x04,0x04, + 0x10,0xa0,0x06,0x02,0x20,0x60,0x85,0x01,0xc0,0xa0,0x44,0x00,0x00,0x61,0x25, + 0x00,0x00,0x22,0x1e,0x00,0x00,0xbc,0x0e,0x00,0x00,0x70,0xfd,0xff,0xff,0x3f, + 0x94,0x52,0x55,0x55,0x4a,0x29,0x22,0xa2}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-reply-with-original-up.xbm --- a/etc/gnus/gnus-summary-reply-with-original-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-reply-with-original-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x22,0x04,0x10,0xaa,0x08,0x51,0x45,0x00,0x22,0x04,0x08,0xaa,0x88,0xa2, - 0x42,0x00,0x11,0x17,0x14,0x54,0xc4,0x4a,0x41,0x82,0x48,0x32,0x0a,0x28,0x22, - 0xc2,0x50,0x82,0x18,0x81,0x05,0x20,0x17,0x01,0x43,0x8a,0x09,0xc1,0x17,0x61, - 0x04,0x3d,0x47,0x1c,0xc3,0x83,0x18,0x85,0x40,0xc0,0x71,0x4c,0x7c,0x60,0x30, - 0xf5,0x23,0xb0,0x6e,0x84,0x20,0xb8,0x21,0x06,0x13,0x4c,0x20,0x04,0x1c,0x36, - 0xa0,0x06,0x30,0x0f,0x60,0x06,0x70,0x07,0xa0,0x05,0xc8,0x09,0x60,0x06,0x04, - 0x10,0x20,0x04,0x02,0x20,0xa0,0x85,0x01,0xc0,0x60,0x46,0x00,0x00,0x21,0x24, - 0x00,0x00,0x62,0x1e,0x00,0x00,0xbc,0x0d,0x00,0x00,0x30,0xfd,0xff,0xff,0xbf, - 0xaa,0xaa,0x2a,0x55,0x49,0x92,0x44,0x49}; + 0x00,0x08,0x00,0x20,0xaa,0x82,0xaa,0x4a,0x00,0x54,0x00,0x00,0xaa,0x02,0x54, + 0x55,0x00,0xa8,0x07,0x00,0x54,0x85,0x5a,0x55,0x02,0x50,0x32,0x80,0x50,0x25, + 0xc2,0x2a,0x02,0x18,0x81,0x41,0x54,0x17,0x01,0x17,0x80,0x09,0xc1,0x23,0x75, + 0x04,0x3d,0x4f,0x18,0xc3,0x83,0x18,0x85,0x40,0xc0,0x61,0x4c,0x7c,0x60,0x30, + 0xf6,0x23,0xb0,0x6e,0x84,0x20,0x98,0x21,0x05,0x13,0x5c,0x20,0x04,0x1c,0x36, + 0x60,0x06,0x30,0x0f,0x60,0x06,0x70,0x07,0xa0,0x05,0xc8,0x09,0x20,0x06,0x04, + 0x10,0x60,0x04,0x02,0x20,0xa0,0x85,0x01,0xc0,0x20,0x46,0x00,0x00,0xa1,0x24, + 0x00,0x00,0x62,0x1e,0x00,0x00,0x7c,0x0d,0x00,0x00,0xb0,0xfc,0xff,0xff,0x3f, + 0x55,0x55,0x4a,0x55,0x24,0x89,0x52,0xa2}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-save-article-file-up.xbm --- a/etc/gnus/gnus-summary-save-article-file-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-save-article-file-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x10,0x20,0x00,0x20,0x85,0x8a,0xaa,0x0a,0x28,0x10,0x00,0x50,0x82,0xfe,0xff, - 0x0b,0x48,0x04,0x00,0xa5,0x12,0x05,0x00,0x09,0x40,0x04,0x00,0x31,0x15,0x06, - 0x00,0x5f,0xa0,0x04,0x00,0x10,0x0a,0x04,0x00,0x50,0x50,0x05,0x00,0x10,0x05, - 0x04,0x00,0x50,0xa8,0x06,0x00,0x30,0xfd,0xff,0x0f,0x10,0x34,0x00,0x0b,0xb0, - 0x2d,0x40,0x0d,0x10,0x34,0x04,0x0b,0x50,0x2d,0x00,0x0d,0x10,0x34,0x21,0x0b, - 0xb0,0x2d,0x00,0x0b,0x10,0x34,0x04,0x0d,0x30,0x2d,0x00,0x0b,0x50,0xf4,0xff, - 0x0d,0x10,0xad,0xb5,0x0a,0x50,0x24,0x4a,0x09,0x10,0xed,0xff,0xfd,0x5f,0xf4, - 0x36,0x4b,0x12,0x6d,0x35,0x2d,0x44,0xb4,0x2d,0x89,0x10,0xea,0x36,0x2f,0x45, - 0xf8,0xff,0x8f,0x10,0x02,0x80,0x20,0x44}; + 0x20,0x08,0x08,0x82,0x8a,0x82,0xa2,0x20,0x20,0x14,0x04,0x15,0x14,0xfd,0xff, + 0x43,0x42,0x04,0x00,0x0d,0x10,0x05,0x00,0x49,0x22,0x06,0x00,0x31,0x88,0x04, + 0x00,0x1f,0x22,0x06,0x00,0x50,0x88,0x04,0x00,0x10,0x22,0x04,0x00,0xb0,0x88, + 0x06,0x00,0x10,0x22,0x04,0x00,0x50,0xfc,0xff,0x0f,0x10,0x36,0x00,0x0b,0xb0, + 0x2c,0x02,0x0d,0x10,0x34,0x10,0x0b,0x50,0x2d,0x00,0x0b,0x10,0x34,0x41,0x0d, + 0xb0,0x2d,0x08,0x09,0x10,0x34,0x00,0x0b,0x50,0x2d,0x01,0x0d,0x10,0xf4,0xff, + 0x0b,0xb0,0xad,0xda,0x0a,0x10,0x44,0x22,0x0d,0x50,0xf6,0xff,0xf9,0x1f,0x6c, + 0x3b,0x4b,0x52,0xb5,0x2d,0x1d,0x08,0x6c,0x35,0x4b,0xa1,0x6a,0x3b,0x29,0x14, + 0xf8,0xff,0x8f,0x40,0x02,0x40,0x2a,0x15}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-summary-save-article-up.xbm --- a/etc/gnus/gnus-summary-save-article-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-summary-save-article-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x00,0x08,0x01,0x40,0xaa,0x42,0x54,0x15,0x00,0x14,0x01,0x20,0xd4,0xff,0xff, - 0x7f,0x82,0x03,0x00,0xf0,0xd0,0x0c,0x00,0x4c,0x82,0x30,0x00,0x43,0xa8,0xc0, - 0xc0,0x40,0xc2,0x80,0x33,0xc0,0x90,0x60,0xcc,0x40,0x8a,0x10,0x00,0x41,0xc1, - 0x08,0x00,0x46,0x94,0x06,0x00,0xd8,0xfc,0xff,0x0f,0x60,0x36,0x00,0x0b,0x40, - 0x2c,0x00,0xfd,0x7f,0x34,0x49,0x2b,0x49,0x2d,0x00,0x4d,0x12,0x34,0x00,0x09, - 0x40,0x2d,0x11,0xaf,0x2a,0x34,0x00,0x19,0x80,0x2d,0x40,0x8d,0x2a,0xf4,0xff, - 0x2b,0x40,0x4d,0xad,0x0c,0x15,0x54,0x91,0x5a,0x20,0xed,0xff,0x0d,0x4a,0x74, - 0x2f,0xa9,0x00,0x6d,0x35,0x1d,0x54,0xb4,0x3a,0x4b,0x01,0x6a,0x37,0x1b,0x54, - 0xf8,0xff,0x4f,0x81,0x02,0x80,0x10,0x28}; + 0x10,0x81,0x04,0x01,0x45,0x28,0x40,0x50,0x88,0x42,0x15,0x05,0xa2,0xff,0xff, + 0x7f,0x88,0x03,0x00,0xf0,0xa2,0x0c,0x00,0x4c,0x88,0x30,0x00,0x43,0xc5,0xc0, + 0xc0,0x40,0x90,0x80,0x33,0xc0,0xa4,0x60,0xcc,0x40,0x82,0x10,0x00,0x41,0xd0, + 0x08,0x00,0x46,0x82,0x06,0x00,0xd8,0xfc,0xff,0x0f,0x60,0x2e,0x00,0x0d,0x40, + 0x34,0x02,0xfb,0x7f,0x36,0x10,0x0d,0x91,0xac,0x00,0x4b,0x24,0x34,0x00,0x2d, + 0x81,0x2d,0x48,0x4b,0x28,0x34,0x02,0x0d,0x85,0x2d,0x00,0xab,0x20,0xf4,0xff, + 0x0d,0x8a,0xa6,0xaa,0xaa,0x20,0x4c,0x55,0x0a,0x85,0xf5,0xff,0x5b,0x20,0x6c, + 0x35,0x8d,0x8a,0xad,0x36,0x2b,0x20,0xf4,0x2a,0x89,0x8a,0x6a,0x3b,0x5d,0x20, + 0xf8,0xff,0x0f,0x85,0x02,0x40,0xa2,0x20}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-uu-decode-uu-up.xbm --- a/etc/gnus/gnus-uu-decode-uu-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-uu-decode-uu-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x10,0x40,0x00,0x01,0x44,0x15,0x54,0x50,0x12,0xa0,0x82,0x82,0x00,0x15,0x20, - 0x28,0xaa,0x40,0x95,0x82,0x01,0x28,0x00,0x28,0xd4,0xff,0xff,0x43,0x82,0x4a, - 0x6d,0x17,0xa8,0x55,0x91,0x42,0x84,0xfd,0xff,0x2a,0x92,0x06,0x40,0x83,0xa0, - 0x05,0xc0,0x2a,0x8a,0x06,0x40,0x83,0xc0,0x84,0x40,0x2a,0x8a,0x65,0xcb,0x82, - 0xd0,0x96,0x44,0x2b,0x82,0x45,0xc0,0x42,0xa8,0x24,0x41,0x16,0x82,0xe5,0xc1, - 0x22,0xd0,0x06,0x42,0x4b,0x82,0x05,0xc4,0x02,0xa8,0x05,0x40,0x56,0x82,0x06, - 0xc0,0x02,0xa8,0x05,0x40,0x57,0x82,0x06,0x40,0x82,0xa8,0xfd,0x7f,0x2b,0x82, - 0x92,0xaa,0x82,0xa8,0x49,0x49,0x2b,0xc2,0xff,0xff,0x83,0x10,0x24,0x00,0x28, - 0x42,0x82,0xaa,0x42,0x94,0x50,0x00,0x10}; + 0x00,0x08,0x10,0x01,0xaa,0x42,0x45,0x54,0x00,0x14,0x10,0x01,0x55,0x41,0x45, + 0x50,0x00,0x0a,0x88,0x0a,0xaa,0xa0,0x22,0x40,0x80,0xff,0xff,0x17,0xaa,0x95, + 0x54,0x43,0x80,0x2a,0xa5,0x0a,0xaa,0xfd,0x7f,0x53,0xc0,0x06,0x40,0x06,0x94, + 0x04,0x40,0x43,0xc2,0x05,0xc0,0x2a,0x90,0x86,0xc0,0x06,0xa2,0x64,0x4b,0x53, + 0x88,0x96,0x44,0x06,0xd2,0x45,0xc0,0x52,0x84,0x25,0xc1,0x06,0x90,0xe6,0x41, + 0x53,0x8a,0x05,0x42,0x06,0xa0,0x06,0xc4,0x52,0x95,0x04,0xc0,0x06,0xc0,0x05, + 0x40,0x53,0x94,0x06,0x40,0x06,0xa2,0x05,0xc0,0x52,0x88,0xfc,0xff,0x06,0xa2, + 0x95,0x12,0x53,0x88,0x4a,0xa9,0x06,0xa2,0xff,0xff,0x53,0x90,0x10,0x00,0x04, + 0x42,0x42,0x55,0x50,0x14,0x28,0x80,0x0a}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus-uu-post-news-up.xbm --- a/etc/gnus/gnus-uu-post-news-up.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus-uu-post-news-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -1,12 +1,12 @@ #define noname_width 32 #define noname_height 32 static char noname_bits[] = { - 0x91,0x91,0x11,0x15,0x28,0x2a,0x52,0x41,0x82,0x80,0x09,0x14,0x28,0xd4,0x86, - 0x42,0x95,0x31,0x3d,0x19,0x21,0x4e,0x61,0x42,0x84,0x0b,0xca,0x29,0xa1,0xff, - 0xff,0x07,0x95,0xaa,0x92,0xb2,0xa0,0xa5,0x54,0x0b,0x8a,0xfc,0x7f,0x52,0xc1, - 0x06,0x40,0x07,0xb5,0x05,0xc0,0x32,0x88,0x05,0xc0,0x4a,0xa2,0x86,0x40,0x03, - 0x88,0x64,0x4b,0x56,0xd5,0x95,0xc4,0x12,0x91,0x46,0x40,0x4b,0xc4,0x24,0x41, - 0x22,0x91,0xe6,0x41,0x17,0xd1,0x05,0xc2,0x52,0x94,0x04,0x44,0x13,0xc2,0x05, - 0x40,0x46,0x90,0x06,0x40,0x13,0x95,0x05,0xc0,0x52,0xc2,0x04,0xc0,0x16,0xa8, - 0xfd,0x7f,0x43,0x84,0xaa,0x54,0x2a,0xb1,0x25,0x49,0x93,0x8a,0xff,0xff,0x27, - 0x10,0x40,0x04,0x10,0x45,0x15,0x51,0x45}; + 0x11,0x11,0x19,0x51,0x4a,0x95,0x82,0x14,0x20,0x40,0x29,0x42,0x0a,0xd5,0x86, + 0x10,0x31,0x31,0x3b,0x53,0x08,0x9d,0xe8,0x10,0xa2,0x43,0x82,0x4b,0x88,0xff, + 0xff,0x03,0xb3,0xaa,0x54,0xbb,0x88,0x55,0xaa,0x02,0xa2,0xfc,0x7f,0x4b,0x88, + 0x06,0xc0,0x12,0xb1,0x05,0x40,0x56,0x8a,0x05,0x40,0x03,0xd0,0x86,0xc0,0xaa, + 0x85,0x64,0x4b,0x06,0xb1,0x95,0xc4,0x32,0x8a,0x46,0x40,0x4b,0xd0,0x24,0x41, + 0x03,0x84,0xe6,0xc1,0x56,0xd9,0x05,0x42,0x12,0x82,0x04,0x44,0x4b,0x94,0x07, + 0xc0,0x22,0xc1,0x04,0x40,0x16,0x95,0x05,0xc0,0x52,0xa0,0x06,0x40,0x13,0x8a, + 0xfd,0xff,0x46,0xd0,0x94,0x52,0x12,0x93,0x29,0xa5,0x5a,0xa4,0xff,0xff,0x03, + 0x10,0x02,0x08,0x55,0x85,0xa8,0xa2,0x00}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/gnus/gnus.xbm --- a/etc/gnus/gnus.xbm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/gnus/gnus.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -7,593 +7,593 @@ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0x7f,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x4a,0xe0,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x49,0xe0,0xff, 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x47,0x51,0x85,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x97,0xaa,0x8a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xb7,0x2c,0x51,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x57,0x2a,0x41,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x49,0x51,0x05,0xfe,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0x52,0x16,0xfe,0x7f,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x96,0x4a, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0x49,0x05, 0xf9,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0x4a,0x29,0x09,0xf4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0x95,0xaa,0x58,0xf4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x7f,0xa5,0x54,0x55,0xe1,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xa5,0x54,0x26,0xe1,0x7f,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x2a,0xa5,0x54,0xf4,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x54,0x49,0x49,0xe4,0x7f,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xa4,0x2a, - 0x25,0xc1,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x2a,0xa5, + 0x2a,0xd1,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x4f,0x29,0x49,0x55,0x84,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab, + 0xff,0xaf,0x52,0x95,0x54,0xc4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab, 0x24,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x57,0xaa,0xaa,0x92,0x51,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x57,0x29,0xa9,0x92,0x11,0x7f,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x57,0xd5,0xfa,0xff,0xff,0xab,0xea,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x52,0x52,0x2a,0x09,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x93,0x2a,0xe5,0xff,0xff,0x95,0xa4,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x95, - 0x2a,0xa5,0x42,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x24,0x91,0xd4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x4a,0x55,0x2a,0x41,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x25,0x29,0xe5,0xff,0xff,0x95,0xa4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0xa4, + 0x24,0xa5,0x14,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0xa5,0xd4,0xff, 0x3f,0x52,0xa9,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x4b,0xaa,0xa4,0x54,0x08,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xaa,0xaa,0xea,0xff,0xdf,0x2a,0x55,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0x49,0x95,0x2a,0x43,0x7e,0xff,0xff,0xff, - 0xff,0xff,0xff,0x3f,0x55,0x4a,0xc9,0xff,0x23,0xa5,0x4a,0xd6,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0x2a,0x55,0x49,0x29, - 0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x49,0xa9,0x24,0xff,0xad,0x52,0x52, - 0xd1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x52, - 0xa5,0x52,0xaa,0x04,0x7d,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x95,0x4a,0x55, - 0xff,0x49,0xaa,0x94,0x96,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x4a,0x29,0xa5,0x52,0x25,0x7c,0xff,0xff,0xff,0xff,0xff,0xff, - 0x4f,0x52,0x55,0xaa,0xfc,0x54,0x25,0x55,0x49,0xfe,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x29,0xa4,0x54,0x4a,0x8a,0x7e,0xff,0xff, - 0xff,0xff,0xff,0xff,0x57,0x55,0x92,0x92,0x7a,0xa5,0x54,0x49,0xaa,0xfe,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xba,0x70,0xa5,0xaa, - 0x24,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x29,0x55,0x55,0x75,0x55,0x4a, - 0x55,0x55,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0x1a,0xfa,0x57,0x92,0x02,0x7d,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0x52,0xa9, - 0xa4,0x2a,0x49,0x95,0x92,0x24,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x5f,0x5d,0xfc,0x97,0xaa,0x4a,0x7c,0xff,0xff,0xff,0xff,0xff, - 0xff,0x55,0x95,0x4a,0x2a,0xa9,0xaa,0x52,0xa9,0x52,0xf5,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x0a,0xfd,0x4f,0x55,0x12,0x7d,0xff, - 0xff,0xff,0xff,0xff,0xff,0x92,0xa4,0x94,0x52,0x2a,0x25,0x95,0x2a,0x95,0xe4, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x2e,0xfc,0x5f, - 0x92,0x42,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0x55,0xaa,0xaa,0x4a,0xa9, - 0x52,0x4a,0x55,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x2f,0x0d,0xff,0x5f,0x49,0x15,0x7e,0xff,0xfd,0xff,0xff,0xff,0x3f,0x25,0xa9, - 0x52,0x92,0x54,0x4a,0xaa,0x54,0x92,0xaa,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xaf,0x56,0xfe,0xbf,0xaa,0x44,0x7c,0xff,0xe5,0xff,0xff, - 0xff,0xbf,0xaa,0x2a,0x95,0xaa,0x4a,0x55,0x95,0x4a,0x55,0x49,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x05,0xfe,0xbf,0x54,0x12,0x7d, - 0xff,0xd9,0xff,0xff,0xff,0x4f,0x49,0x41,0xaa,0x24,0xa9,0xa4,0xa8,0x94,0x24, - 0x55,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0xaa,0xfe, - 0xbf,0x92,0x42,0x7c,0x7f,0x25,0xff,0xff,0xff,0xaf,0x54,0x12,0x49,0x55,0x25, - 0x55,0x4a,0xa5,0xaa,0x24,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x4b,0x03,0xfe,0x7f,0xaa,0x12,0x7e,0x7f,0x55,0xfd,0xff,0xff,0x95,0x2a, - 0x48,0x94,0x4a,0x55,0x49,0x95,0x2a,0x55,0x55,0xf9,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x57,0x96,0xff,0xff,0x52,0x42,0x7c,0xff,0x92,0xfe, - 0xff,0xff,0x52,0x0a,0x02,0x51,0x52,0x92,0xaa,0x52,0x52,0x49,0x4a,0xe5,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x21,0xff,0x7f,0x95,0x12, - 0x7d,0xff,0x55,0xfa,0xff,0xff,0xaa,0xa2,0x28,0xa4,0x54,0x55,0x02,0x48,0x95, - 0x92,0x52,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x8b, - 0xff,0xff,0xaa,0x48,0x7c,0xff,0x49,0xf5,0xff,0x3f,0x49,0x09,0x02,0x81,0x4a, - 0x4a,0xa9,0x02,0x48,0x55,0x29,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xaf,0x83,0xff,0xff,0x92,0x02,0x7f,0xff,0x2a,0xf9,0xff,0xaf,0x92, - 0x22,0x28,0x4a,0x55,0xa9,0x04,0xa8,0xa2,0x54,0x55,0xa9,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xef,0xef,0xef,0xff,0xff,0x55,0x15,0x7e,0xff,0xa4, - 0xea,0xff,0xaf,0xaa,0x88,0x82,0x10,0x24,0x55,0x90,0x02,0x48,0x4a,0x4a,0xa5, - 0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xdf,0xdf,0xe7,0xff,0xff,0x49, - 0x82,0x7e,0xff,0x2b,0xd5,0xff,0x25,0x55,0x22,0x1c,0x42,0xa9,0x12,0x41,0x28, - 0x81,0x52,0x29,0x55,0xfe,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xe7,0xff, - 0xe7,0xff,0xff,0xaa,0x28,0x7e,0xff,0xa5,0xe4,0xff,0xaa,0x92,0x80,0xff,0x10, - 0x54,0x49,0x14,0x42,0x28,0x2a,0xa5,0x92,0xfe,0xff,0xff,0xff,0xcf,0xff,0xff, - 0xff,0xff,0xd7,0xff,0xff,0xff,0xff,0x94,0x02,0x7f,0xff,0xab,0x4a,0x1f,0x49, - 0x2a,0xca,0xff,0x42,0x92,0x2a,0x41,0x08,0x41,0x4a,0x55,0xaa,0xfc,0xff,0xff, - 0xff,0xef,0xff,0xff,0xff,0xff,0xe9,0xff,0xff,0xff,0x7f,0xa9,0x54,0x7e,0xff, - 0x49,0x52,0xd2,0xaa,0x92,0xf0,0xff,0x91,0xa0,0x14,0x10,0x42,0x94,0x50,0x29, - 0x95,0xf2,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff, - 0x4a,0x01,0x7e,0xff,0xab,0xaa,0x14,0x25,0x15,0xfa,0xff,0x0f,0x4a,0x49,0x45, - 0x09,0x01,0x2a,0xa5,0xa4,0xfa,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xf2, - 0xff,0xff,0xff,0x7f,0x95,0x54,0x7f,0xff,0x27,0x25,0x55,0xa9,0x84,0xfc,0xff, - 0xaf,0x20,0x05,0xf8,0x7f,0xa4,0xa0,0x94,0xaa,0xd4,0xff,0xff,0xff,0xcb,0xff, - 0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0x7f,0x52,0x01,0x7f,0xff,0xab,0x54,0xa9, - 0x4a,0x11,0xff,0xff,0x1f,0x4a,0x95,0xff,0xff,0x11,0x4a,0x55,0x49,0xa9,0xff, - 0xff,0xff,0xd4,0xff,0xff,0xff,0x7f,0xfa,0xff,0xff,0xff,0xff,0xaa,0x24,0x7f, - 0xff,0x97,0x2a,0x95,0x54,0x45,0xfe,0xff,0xbf,0x90,0x82,0xff,0xff,0x8f,0x80, - 0x4a,0x2a,0x95,0xff,0xff,0xff,0xea,0xff,0xff,0xff,0x7f,0xd5,0xff,0xff,0xff, - 0x7f,0x25,0x41,0x7f,0xff,0xa9,0xa4,0x52,0x29,0x10,0xff,0xff,0xff,0x42,0xe8, - 0xff,0xff,0x5f,0x2a,0xa9,0x52,0x29,0xfd,0xff,0x3f,0xe9,0xff,0xff,0xff,0xff, - 0x1c,0xff,0xff,0xff,0x7f,0xa9,0x14,0x7f,0xff,0x49,0x55,0x4a,0x4a,0xc5,0xff, - 0xff,0xff,0x95,0xc2,0xff,0xff,0x3f,0x40,0x54,0x55,0xa5,0xfa,0xff,0xbf,0xda, - 0xff,0xff,0xff,0xbf,0x4a,0xff,0xff,0xff,0xff,0x54,0x41,0x7f,0xff,0x92,0x92, - 0xaa,0x12,0x90,0xff,0xff,0x7f,0x42,0xe8,0xff,0xff,0xff,0x12,0x25,0x49,0xaa, - 0xf4,0xff,0xaf,0xe4,0xff,0xff,0xff,0x3f,0x8d,0xff,0xff,0xff,0x7f,0x25,0x0a, - 0x7f,0xff,0x50,0xa9,0x52,0x55,0xc5,0xff,0xff,0x7f,0x15,0xf2,0xff,0xff,0xff, - 0x40,0x90,0x2a,0x95,0x8a,0xfe,0xab,0xca,0xff,0xff,0xff,0x9f,0xa6,0xff,0xff, - 0xff,0xff,0xaa,0x80,0x7f,0xff,0x2a,0x55,0x4a,0x0a,0xf0,0xff,0xff,0x7f,0x45, - 0xf8,0xff,0xff,0xff,0x0b,0x55,0x52,0x29,0xb5,0x2a,0x49,0xe1,0xd7,0xff,0xff, - 0xa7,0x8a,0xff,0xff,0xff,0x7f,0x49,0xaa,0x7f,0xff,0xa8,0x24,0xa9,0x82,0xf4, - 0xff,0xff,0x9f,0x1e,0xfa,0xff,0xff,0xff,0x47,0xa0,0xaa,0x4a,0x49,0x92,0x2a, - 0xf5,0xaf,0xff,0xff,0x57,0xc3,0xff,0xff,0xff,0x7f,0xaa,0x80,0x7f,0x7f,0x52, - 0x55,0x95,0x14,0xfe,0xff,0xff,0x5f,0x4f,0xf8,0xff,0xff,0xff,0x2f,0xa5,0x24, - 0x55,0x95,0xaa,0x54,0xe2,0xd3,0xff,0xff,0x29,0xd5,0xff,0xff,0xff,0xff,0x52, - 0xca,0x7f,0x3f,0x80,0x92,0x4a,0x81,0xfe,0xff,0xff,0x57,0x9d,0xfe,0xff,0xff, - 0xff,0x1f,0x08,0x95,0xa2,0xa4,0x52,0x4a,0xf5,0x2b,0xff,0x7f,0x95,0xc1,0xff, - 0xff,0xff,0xff,0xaa,0x80,0x7f,0xbf,0x5a,0xaa,0x54,0x14,0xff,0xff,0xff,0xa7, - 0x1c,0xfe,0xff,0xff,0xff,0x7f,0xa1,0xaa,0x4c,0x55,0x4a,0xa9,0xf0,0xcb,0xff, - 0x5f,0xe5,0xe5,0xff,0xff,0xff,0x7f,0x92,0xaa,0x7f,0x3f,0x40,0x55,0x12,0xc1, - 0xff,0xff,0xff,0xab,0xba,0xfe,0xff,0xff,0xff,0x7f,0x08,0x52,0x2a,0x29,0x55, - 0x95,0xfa,0x29,0xfd,0xab,0x94,0xf0,0xff,0xff,0xff,0x7f,0x55,0x80,0x7f,0xff, - 0x92,0xa4,0x4a,0xc4,0xff,0xff,0xff,0x55,0x38,0xff,0xff,0xff,0xff,0xff,0xa2, - 0xa4,0x52,0xa5,0x24,0xa5,0xf8,0x55,0x2a,0x49,0xa9,0xf9,0xff,0xff,0xff,0x7f, - 0x29,0xc9,0x7f,0x7f,0x04,0x95,0x12,0xf0,0xff,0xff,0xff,0xaa,0xfe,0xff,0xff, - 0xff,0xff,0xff,0x09,0x54,0x49,0xaa,0xaa,0x52,0xfa,0x95,0x92,0x2a,0x55,0xf0, - 0xff,0xff,0xff,0x7f,0x4a,0xe2,0x7f,0xff,0x50,0x54,0x40,0xf9,0xff,0xff,0xff, - 0x12,0xfc,0xff,0xff,0xff,0xff,0xff,0xa3,0x48,0x56,0x49,0x49,0xaa,0xf8,0xa4, - 0xaa,0x54,0x25,0xfd,0xff,0xff,0xff,0xbf,0x52,0xc8,0x7f,0xff,0x05,0x01,0x15, - 0xf8,0xff,0xff,0x7f,0x8a,0xfe,0xff,0xff,0xff,0xff,0xff,0x0f,0x22,0x25,0x55, - 0xaa,0x4a,0xfe,0xaa,0x54,0x4a,0x29,0xf8,0xff,0xff,0xff,0x7f,0x2a,0xc2,0x7f, - 0xff,0x11,0x24,0xa0,0xfe,0xff,0xff,0x7f,0x25,0xff,0xff,0xff,0xff,0xff,0xff, - 0x2f,0xa8,0x54,0xa9,0x52,0x29,0x7c,0x49,0x49,0x29,0x95,0xfc,0xff,0xff,0xff, - 0xbf,0x92,0xe8,0x7f,0xff,0x47,0x89,0x0a,0xfe,0xff,0xff,0x3f,0x45,0xff,0xff, - 0xff,0xff,0xff,0xff,0x9f,0x82,0x4a,0x25,0x95,0x14,0xbf,0x2a,0x55,0xa5,0x04, - 0xfd,0xff,0xff,0xff,0x7f,0x2a,0xe2,0x7f,0xff,0x17,0x20,0x20,0xff,0xff,0xff, - 0x5f,0x93,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x94,0x94,0x4a,0x2a,0x45,0x7e, - 0x52,0x49,0xaa,0x12,0xfc,0xff,0xff,0xff,0xbf,0x92,0xe8,0x7f,0xff,0x87,0x0a, - 0xca,0xff,0xff,0xff,0x5f,0x85,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x21,0xaa, - 0x54,0xa5,0x92,0x9e,0xaa,0xaa,0x2a,0x45,0xff,0xff,0xff,0xff,0x7f,0x15,0xe2, - 0x7f,0xff,0x1f,0xa0,0xe0,0xff,0xff,0xff,0xa7,0xd0,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x84,0x24,0xa9,0x54,0x09,0xbf,0x24,0x25,0x49,0x11,0xfe,0xff,0xff, - 0xff,0x9f,0x94,0xf8,0x7f,0xff,0x9f,0x14,0xf8,0xff,0xff,0xff,0xab,0xe5,0xff, - 0xff,0xff,0xff,0xbf,0xff,0xff,0x21,0x54,0x95,0x4a,0x42,0x5f,0x55,0xa9,0xaa, - 0x44,0xff,0xff,0xff,0xff,0x5f,0x12,0xf2,0x7f,0xff,0x7f,0x42,0xfd,0xff,0xff, - 0xff,0x57,0xf0,0xff,0xff,0xff,0xff,0x4f,0xfe,0xff,0x87,0xa8,0x52,0x29,0x08, - 0x2f,0x49,0x4a,0x49,0x12,0xff,0xff,0xff,0xff,0xbf,0x5a,0xf8,0x7f,0xff,0xff, - 0x9f,0xff,0xff,0xff,0xff,0xa9,0xfc,0xff,0xff,0xff,0xff,0x5f,0xf9,0xff,0x27, - 0x42,0xaa,0x94,0xc2,0x5f,0x55,0x55,0xaa,0xc0,0xff,0xff,0xff,0xff,0x5f,0x05, - 0xf9,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x15,0xfa,0xff,0xff,0xff,0xff, - 0x97,0xea,0xff,0x9f,0x88,0x24,0x45,0x88,0x4f,0x2a,0xa9,0x12,0x92,0xff,0xff, - 0xff,0xff,0x5f,0x4a,0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xfc, - 0xff,0xff,0xff,0xff,0xab,0xea,0xff,0x1f,0x22,0x51,0x10,0xe2,0xbf,0x92,0x4a, - 0x0a,0xc4,0xff,0xff,0xff,0xff,0x5f,0x19,0xf9,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0x2a,0xfe,0xff,0xff,0xff,0xff,0x27,0x95,0xff,0x7f,0x08,0x84,0x42, - 0xf8,0x5f,0xa5,0x94,0xa2,0xd0,0xff,0xff,0xff,0xff,0x2f,0x0d,0xfc,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0x45,0xff,0xff,0xff,0xff,0xff,0xa9,0xa4,0xff, - 0x7f,0x82,0x22,0x10,0xfa,0x3f,0xa9,0x52,0x09,0xe4,0xff,0xff,0xff,0xff,0x9f, - 0x4a,0xfd,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x14,0xff,0xff,0xff,0x7f, - 0xff,0x55,0xa9,0xff,0xff,0x28,0x88,0xa2,0xfc,0xbf,0x2a,0x55,0xa0,0xf0,0xff, - 0xff,0xff,0xff,0xaf,0x24,0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x87, - 0xff,0xff,0xff,0x7f,0xfd,0x25,0x55,0xfe,0xff,0x43,0x22,0x08,0xfe,0x3f,0x4a, - 0x15,0x09,0xfc,0xff,0xff,0xff,0xff,0x5f,0x0d,0xfe,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0x4f,0xd1,0xff,0xff,0xff,0x5f,0x7d,0x4a,0xa5,0xfe,0xff,0x0b,0x89, - 0x24,0xff,0x5f,0x54,0x42,0xa4,0xfe,0xff,0xff,0xff,0xff,0x27,0xa5,0xfe,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xe1,0xff,0xff,0xff,0xaf,0x7e,0x55,0x29, - 0xfd,0xff,0x47,0x00,0xc1,0xff,0x1f,0x81,0x10,0x01,0xfe,0xff,0xff,0xff,0xff, - 0x57,0x0d,0xfe,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xd7,0xea,0xff,0xff,0xff, - 0x97,0xbf,0x24,0x55,0xfd,0xff,0x1f,0x55,0xf4,0xff,0x3f,0x14,0x42,0x94,0xff, - 0xff,0xff,0xff,0xff,0x4f,0x23,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x2b, - 0xf0,0xff,0xff,0xff,0x55,0x5f,0xaa,0x92,0xfc,0xff,0xff,0x00,0xf8,0xff,0x1f, - 0x41,0x11,0x81,0xff,0xff,0xff,0xff,0xff,0xa7,0x0a,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0x67,0xf9,0xff,0xff,0xff,0xa5,0x5f,0x49,0xa5,0xfa,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x24,0x04,0xd4,0xff,0xff,0xff,0xff,0xff,0x2f,0xa3,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x29,0xfa,0xff,0xff,0xff,0xd4,0x9f,0xaa, - 0x54,0xfd,0xff,0xff,0xff,0xff,0xff,0x3f,0x09,0x51,0xf1,0xff,0xff,0xff,0xff, - 0xff,0xab,0x0a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xfc,0xff,0xff, - 0x3f,0x55,0xa4,0x92,0x2a,0xf9,0xff,0xff,0xff,0xff,0xff,0x7f,0x20,0x04,0xfc, - 0xff,0xff,0xff,0xff,0xff,0x27,0x21,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0x34,0xfe,0xff,0xff,0x5f,0x69,0xad,0x54,0x92,0xf4,0xff,0xff,0xff,0xff,0xff, - 0xff,0x0a,0x41,0xfd,0xff,0xff,0xff,0xff,0xff,0xab,0x8b,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0x8a,0xfe,0xff,0xff,0x5f,0x15,0x5c,0x55,0x55,0xf5,0xff, - 0xff,0xff,0xff,0xff,0xff,0x21,0x14,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xa1, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x3f,0x2d,0xff,0xff,0xff,0x4f,0x2a,0x3f, - 0x92,0xa4,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x8b,0xc2,0xff,0xff,0xff,0xff, - 0xff,0xff,0xab,0x93,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x7f,0x85,0xff,0xff, - 0xff,0x55,0x81,0xbf,0xaa,0x4a,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xf8, - 0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xc8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0x9f,0xd2,0xff,0xff,0xff,0x92,0x2a,0x5f,0x48,0x55,0xf9,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc9,0xc2,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xbf,0xc2,0xff,0xff,0xff,0x2a,0x81,0x0f,0x29,0xa9,0xea, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab, - 0xe8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x5f,0xe9,0xff,0xff,0xbf,0xa4,0xe4, - 0x5f,0xa4,0x94,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xd4,0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x27,0xf4,0xff, - 0xff,0x3f,0x55,0xd0,0x07,0x51,0x25,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x69,0xe8,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0x57,0xf1,0xff,0xff,0xaf,0x2a,0xe5,0x4b,0x44,0xaa,0xf2,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xe2,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0x97,0xfc,0xff,0xff,0x57,0x12,0xf0,0x0f,0x91,0x52, - 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x72,0xe8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x53,0xf8,0xff,0xff,0x25,0x49, - 0xf5,0x5f,0x44,0x29,0xe9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x6a,0xf2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x15,0xfd, - 0xff,0xff,0xa9,0x0a,0xf8,0x7f,0x90,0x4a,0xe5,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaa,0xf8,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0x4a,0xfe,0xff,0x7f,0x95,0x92,0xfa,0xff,0x05,0xa9,0xf4,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x35,0xf9,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0x12,0xff,0xff,0x2f,0xa5,0x40,0xfc,0xff,0x51, - 0x4a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0x3a,0xfc,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x6a,0xff,0xff,0x57,0xa9, - 0x14,0xfe,0xff,0x07,0xaa,0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xbf,0x5a,0xf9,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x09, - 0xff,0xff,0x4b,0x4a,0x40,0xff,0xff,0x57,0x49,0xf5,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x1c,0xfc,0xff,0x7f,0xff,0xff, - 0xff,0xff,0x7f,0xaa,0xff,0x7f,0xa9,0x2a,0x95,0xff,0xff,0x07,0x55,0xea,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x3d,0xfd, - 0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x55,0xfe,0x7f,0x95,0x14,0xc0,0xff,0xff, - 0x2f,0x52,0xe9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x5f,0x8d,0xfc,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x49,0xeb,0x57,0x4a, - 0x05,0xf9,0xff,0xff,0x9f,0x28,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x5f,0x2e,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x9f, - 0x2a,0xa9,0xa4,0x54,0x29,0xfc,0xff,0xff,0x1f,0xa6,0xf4,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x8e,0xfe,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xbf,0xa4,0x54,0x95,0x52,0x02,0xfd,0xff,0xff,0xbf,0x52,0xf5, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x2f, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,0x55,0x25,0xa9,0x4a,0x29,0xfe,0xff, - 0xff,0x3f,0x94,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xaf,0x87,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x2a,0x55,0xa5, - 0x54,0x80,0xff,0xff,0xff,0xff,0x54,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x27,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0x97,0xa4,0xa4,0x4a,0x29,0xa5,0xff,0xff,0xff,0x7f,0xa4,0xf4,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x17,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0x57,0x95,0x2a,0x29,0x05,0xe0,0xff,0xff,0xff,0xff,0x94, - 0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7, - 0xc7,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xaf,0xaa,0x54,0xaa,0x52,0xf5,0xff, - 0xff,0xff,0xff,0x54,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xaf,0x8b,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x27,0x49,0x4a, - 0xa5,0x04,0xf8,0xff,0xff,0xff,0xff,0xa4,0xf4,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xab,0xa3,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0x4b,0x55,0xa9,0x4a,0x92,0xfc,0xff,0xff,0xff,0xff,0x49,0xf9,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xd7,0xff,0xff,0xff,0xff,0xff,0xa7,0x8b,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0x57,0x49,0x25,0xa9,0x20,0xfe,0xff,0xff,0xff,0xff, - 0x2b,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff,0xff, - 0xd3,0xc3,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x93,0x2a,0x55,0x0a,0x82,0xff, - 0xff,0xff,0xff,0xff,0x55,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xff, - 0xff,0xff,0xff,0xff,0xd7,0xd5,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x52, - 0xa9,0xaa,0xd4,0xff,0xff,0xff,0xff,0xff,0x49,0xf6,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xf1,0xff,0xff,0xff,0xff,0xff,0xd5,0xc3,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xab,0x4a,0x25,0x01,0xe0,0xff,0xff,0xff,0xff,0xff,0x55,0xf1,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xe5,0xfd,0xff,0xff,0xff,0xff,0xd3,0xe8,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,0xa9,0x54,0xa9,0xfa,0xff,0xff,0xff,0xff, - 0xff,0xa5,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe1,0xfa,0xff,0xff,0xff, - 0xff,0xe9,0xe2,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x27,0x95,0x4a,0x04,0xf8, - 0xff,0xff,0xff,0xff,0xff,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf4, - 0xfd,0xff,0xff,0xff,0xff,0xca,0xe8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xa7, - 0x4a,0x12,0x21,0xfd,0xff,0xff,0xff,0xff,0xff,0x35,0xf9,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0x61,0xf9,0xff,0xff,0xff,0xff,0x74,0xe2,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0x47,0xb2,0x42,0x84,0xff,0xff,0xff,0xff,0xff,0xff,0x45,0xf8, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe4,0xfa,0xff,0xff,0xff,0xff,0x72,0xe9, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x97,0x8a,0x10,0xa1,0xff,0xff,0xff,0xff, - 0xff,0xff,0x55,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb1,0xfc,0xff,0xff, - 0xff,0xff,0x6a,0xe0,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x07,0x22,0x42,0xc4, - 0xff,0xff,0xff,0xff,0xff,0xff,0x29,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xbf, - 0x74,0xfd,0xff,0xff,0xff,0x7f,0xaa,0xfa,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xaf,0x88,0x14,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfd,0xff,0xff,0xff, - 0xff,0xff,0xff,0x3f,0x50,0xfe,0xff,0xff,0xff,0x7f,0x35,0xf0,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0x07,0x22,0x40,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x25, - 0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0xba,0xfc,0xff,0xff,0xff,0xbf,0xb4, - 0xf4,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x9f,0x88,0x14,0xfe,0xff,0xff,0xff, - 0xff,0xff,0xff,0x53,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0x98,0xfe,0xff, - 0xff,0xff,0x7f,0x1a,0xf1,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x1f,0x22,0xc2, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x15,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xaf,0x56,0xfd,0xff,0xff,0xff,0x9f,0x52,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xbf,0x80,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x25,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xff,0x0f,0x56,0xfe,0xff,0xff,0xff,0x5f,0x1d,0xf8,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0x7f,0x0a,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x89,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x23,0x4b,0xff,0xff,0xff,0xff,0x3f, - 0x49,0xf9,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xf1,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0b,0xab,0xfe, - 0xff,0xff,0xff,0xbf,0x1c,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x93,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xa1,0x93,0xff,0xff,0xff,0xff,0x4f,0x4d,0xfd,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x85,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x95,0xab,0xff,0xff,0xff,0xff,0x2f,0x05,0xfc,0xff, + 0xff,0xff,0x29,0x55,0x55,0x55,0x41,0x7e,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xa9,0x54,0xea,0xff,0xdf,0x2a,0x55,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x4a,0x49,0x12,0x7e,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x55,0xa5,0x92,0xff,0x23,0xa5,0x4a,0xd6,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0xa4,0x94,0xaa,0x42, + 0x7d,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0x2a,0xa9,0xff,0xad,0x92,0x24, + 0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a, + 0x95,0x52,0x52,0x29,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x52,0x49,0x55, + 0xfe,0x91,0x54,0x55,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0x49,0x29,0x55,0x25,0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0x95,0xaa,0x92,0x7e,0x55,0x55,0xa9,0x4a,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0x50,0x95,0xaa,0x24,0x7e,0xff,0xff, + 0xff,0xff,0xff,0xff,0x57,0x2a,0x95,0x54,0x79,0x95,0x92,0x92,0x94,0xfc,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb9,0x62,0x29,0x49, + 0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x49,0x49,0x95,0xba,0xa4,0x54, + 0xaa,0x52,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf, + 0x1a,0xf8,0xa7,0xaa,0x22,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x52, + 0x2a,0x75,0x55,0xa5,0x24,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xbf,0x5a,0xfd,0x57,0x92,0x94,0x7e,0xff,0xff,0xff,0xff,0xff, + 0xff,0x4a,0x4a,0x55,0x49,0x89,0x92,0x94,0xaa,0x94,0xf4,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xfc,0x2f,0x55,0x05,0x7c,0xff, + 0xff,0xff,0xff,0xff,0xff,0x55,0xa9,0x4a,0x55,0x2a,0x55,0x55,0x55,0x55,0xe5, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x4e,0xfd,0x5f, + 0x29,0xa5,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0xa4,0x54,0x52,0x4a,0x55,0xa9, + 0xa4,0x24,0xa5,0x94,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x2f,0x1d,0xfe,0x3f,0x95,0x04,0x7c,0xff,0xfd,0xff,0xff,0xff,0x3f,0x49,0xa5, + 0x54,0xa9,0xa4,0x92,0x4a,0x49,0x4a,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xaf,0x44,0xfe,0x5f,0xa9,0x52,0x7d,0xff,0xe5,0xff,0xff, + 0xff,0x5f,0x55,0x92,0x2a,0x95,0x52,0x4a,0x52,0xaa,0x52,0x4a,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x16,0xff,0xbf,0x4a,0x05,0x7c, + 0xff,0xd9,0xff,0xff,0xff,0x5f,0x95,0x42,0xa5,0x52,0x95,0xaa,0xaa,0xaa,0x94, + 0x54,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x43,0xfe, + 0xbf,0x54,0x52,0x7d,0x7f,0x25,0xff,0xff,0xff,0xa7,0xa4,0x28,0x92,0x54,0x4a, + 0xa5,0x4a,0x92,0xaa,0x4a,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xab,0x12,0xfe,0x7f,0xa5,0x02,0x7c,0x7f,0x55,0xfd,0xff,0xff,0x95,0x2a, + 0x82,0x54,0xa5,0x54,0x2a,0xa9,0x2a,0xa5,0x52,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x27,0x4b,0xff,0xff,0x4a,0x29,0x7d,0xff,0x92,0xfe, + 0xff,0xff,0x55,0x92,0x20,0xa8,0x94,0x2a,0xa5,0x94,0x52,0x29,0xa9,0xf4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x01,0xff,0x7f,0x52,0x42, + 0x7c,0xff,0x25,0xf9,0xff,0x7f,0xaa,0x02,0x8a,0x40,0x29,0x49,0x09,0x41,0x4a, + 0x55,0x25,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57, + 0xff,0xff,0x95,0x12,0x7d,0xff,0xa9,0xfa,0xff,0x7f,0x25,0xa9,0x20,0x2a,0xa5, + 0xaa,0x42,0x92,0x54,0x92,0x54,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xaf,0x83,0xff,0xff,0xa9,0x42,0x7e,0xff,0xaa,0xf4,0xff,0xaf,0x54, + 0x01,0x82,0x80,0xaa,0x54,0x14,0x08,0xa2,0xaa,0x4a,0xd2,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xef,0xcf,0xd7,0xff,0xff,0x52,0x12,0x7f,0xff,0x4a, + 0xea,0xff,0x57,0x92,0xaa,0x28,0x24,0x29,0x25,0x81,0x82,0x08,0x49,0x52,0x55, + 0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xdf,0xef,0xe7,0xff,0xff,0x2a, + 0x05,0x7e,0xff,0x55,0xd5,0xff,0xa5,0x2a,0x00,0x8e,0x10,0x4a,0x89,0x24,0x28, + 0xa0,0xaa,0x2a,0x49,0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xe7,0xff, + 0xef,0xff,0xff,0xa5,0x50,0x7e,0xff,0x25,0xe5,0xff,0x2a,0xa5,0x52,0x7f,0x85, + 0x54,0x35,0x08,0x82,0x0a,0x55,0x95,0xaa,0xfc,0xff,0xff,0xff,0xcf,0xff,0xff, + 0xff,0xff,0xd7,0xff,0xff,0xff,0x7f,0x52,0x85,0x7e,0xff,0xab,0x94,0x1e,0x55, + 0x2a,0xc8,0xff,0x10,0x90,0x92,0xa0,0x08,0x20,0x24,0x52,0x25,0xfd,0xff,0xff, + 0xff,0xef,0xff,0xff,0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0x94,0x10,0x7e,0xff, + 0x93,0xaa,0x6a,0x49,0x49,0xf2,0xff,0x85,0x52,0x09,0x0a,0xa2,0x4a,0x92,0x29, + 0xa9,0xf2,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0x7f, + 0x55,0x25,0x7f,0xff,0x55,0x49,0x49,0x95,0x0a,0xf9,0xff,0x17,0x48,0x26,0x50, + 0x08,0x00,0xa9,0x4a,0x95,0xfa,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xf2, + 0xff,0xff,0xff,0xff,0x92,0x80,0x7e,0xff,0xa7,0x54,0xaa,0xa4,0x52,0xfc,0xff, + 0xaf,0x42,0x89,0xfa,0xbf,0x54,0x20,0xa9,0xa4,0xd4,0xff,0xff,0xff,0xcb,0xff, + 0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,0x54,0x29,0x7f,0xff,0x4b,0xa5,0x92, + 0x2a,0x01,0xff,0xff,0x1f,0xa8,0x22,0xff,0xff,0x01,0xa5,0x2a,0x55,0xa9,0xff, + 0xff,0xff,0xd4,0xff,0xff,0xff,0x7f,0xfa,0xff,0xff,0xff,0x7f,0xa5,0x04,0x7f, + 0xff,0x57,0x2a,0x55,0xa9,0x54,0xfe,0xff,0x3f,0x05,0x89,0xff,0xff,0x5f,0x48, + 0x92,0x2a,0x95,0xff,0xff,0xff,0xea,0xff,0xff,0xff,0xff,0xd2,0xff,0xff,0xff, + 0x7f,0x2a,0x91,0x7f,0xff,0xa9,0x54,0x4a,0x52,0x02,0xff,0xff,0xff,0x50,0xd1, + 0xff,0xff,0x1f,0x81,0xaa,0xa4,0x52,0xfe,0xff,0x3f,0xe9,0xff,0xff,0xff,0x7f, + 0x1d,0xff,0xff,0xff,0xff,0x54,0x41,0x7f,0xff,0x93,0x92,0x52,0x95,0xc8,0xff, + 0xff,0xff,0x8b,0xc4,0xff,0xff,0x7f,0x24,0xa5,0x2a,0x49,0xf9,0xff,0x7f,0xd5, + 0xff,0xff,0xff,0xbf,0x4a,0xff,0xff,0xff,0xff,0x4a,0x14,0x7f,0xff,0x28,0xa5, + 0x94,0x2a,0xa0,0xff,0xff,0x7f,0x22,0xf0,0xff,0xff,0x7f,0x12,0x94,0xa4,0xaa, + 0xea,0xff,0xaf,0xea,0xff,0xff,0xff,0x5f,0x8e,0xff,0xff,0xff,0x7f,0xa9,0x40, + 0x7f,0xff,0x48,0x55,0x55,0x12,0xca,0xff,0xff,0xff,0x0a,0xf5,0xff,0xff,0xff, + 0x80,0x52,0x95,0x54,0xaa,0xfe,0x55,0xc4,0xff,0xff,0xff,0x5f,0xa5,0xff,0xff, + 0xff,0xff,0x94,0x14,0x7f,0xff,0x52,0x2a,0xa9,0x4a,0xe1,0xff,0xff,0xbf,0x24, + 0xf0,0xff,0xff,0xff,0x0b,0x28,0xa9,0x92,0x24,0x55,0x49,0xe5,0xd7,0xff,0xff, + 0xa7,0x8a,0xff,0xff,0xff,0x7f,0xa5,0xc0,0x7f,0xff,0x50,0x49,0x95,0x04,0xf8, + 0xff,0xff,0x5f,0x1f,0xfd,0xff,0xff,0xff,0x47,0x45,0x55,0xaa,0xaa,0x4a,0xaa, + 0xea,0xaf,0xff,0xff,0x2b,0xc3,0xff,0xff,0xff,0x7f,0x55,0x94,0x7f,0x7f,0x4a, + 0x55,0x52,0x51,0xfe,0xff,0xff,0x5f,0x4e,0xf8,0xff,0xff,0xff,0x1f,0x50,0x92, + 0x52,0x49,0xa9,0x92,0xe4,0xd3,0xff,0xff,0x4b,0xd5,0xff,0xff,0xff,0xff,0x94, + 0xc0,0x7f,0x3f,0xa0,0xa4,0xaa,0x04,0xfe,0xff,0xff,0xa7,0x1d,0xfd,0xff,0xff, + 0xff,0x9f,0x84,0xaa,0x4a,0xaa,0x24,0x55,0xf2,0x2b,0xff,0x7f,0xa9,0xc1,0xff, + 0xff,0xff,0x7f,0x4a,0x95,0x7f,0xbf,0x2a,0x95,0x24,0x50,0xff,0xff,0xff,0x97, + 0x5e,0xfe,0xff,0xff,0xff,0x3f,0x92,0x24,0x95,0x92,0xaa,0xa4,0xf2,0xcb,0xff, + 0x5f,0xd5,0xe5,0xff,0xff,0xff,0xff,0x52,0x80,0x7f,0x3f,0xa0,0x52,0x15,0x85, + 0xff,0xff,0xff,0xd7,0x38,0xfe,0xff,0xff,0xff,0xff,0x20,0xaa,0x52,0x55,0x55, + 0x55,0xf9,0x29,0xfd,0xab,0xa4,0xf0,0xff,0xff,0xff,0x7f,0x29,0xa9,0x7f,0xff, + 0x42,0x25,0x49,0xe8,0xff,0xff,0xff,0x69,0x7a,0xff,0xff,0xff,0xff,0xff,0x82, + 0x52,0xaa,0x24,0x89,0x4a,0xf8,0x55,0x2a,0x49,0x95,0xf5,0xff,0xff,0xff,0xbf, + 0x2a,0xc4,0x7f,0x7f,0x90,0x54,0x15,0xe2,0xff,0xff,0xff,0x25,0xbc,0xff,0xff, + 0xff,0xff,0xff,0x29,0x48,0x49,0xaa,0xaa,0xa4,0xfa,0x95,0x92,0x54,0x52,0xf0, + 0xff,0xff,0xff,0xbf,0x4a,0xd1,0x7f,0xff,0x05,0xaa,0x40,0xf8,0xff,0xff,0x7f, + 0xaa,0xfc,0xff,0xff,0xff,0xff,0xff,0x43,0xa9,0xaa,0x4a,0x52,0xa9,0xf8,0xa4, + 0xaa,0x52,0x95,0xfc,0xff,0xff,0xff,0x7f,0x52,0xc0,0x7f,0xff,0xa1,0x00,0x24, + 0xfa,0xff,0xff,0xff,0x0a,0xfe,0xff,0xff,0xff,0xff,0xff,0x17,0x92,0x24,0xa5, + 0x2a,0x55,0xfe,0xaa,0xa4,0x2a,0x29,0xf9,0xff,0xff,0xff,0xbf,0x2a,0xea,0x7f, + 0xff,0x05,0x92,0x90,0xfc,0xff,0xff,0xbf,0xa4,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0xa0,0xaa,0x54,0x49,0x25,0x7c,0x49,0x95,0xa4,0x12,0xfc,0xff,0xff,0xff, + 0x7f,0x8a,0xe0,0x7f,0xff,0xa3,0x04,0x05,0xfe,0xff,0xff,0xbf,0x06,0xff,0xff, + 0xff,0xff,0xff,0xff,0x1f,0x49,0x95,0x52,0xaa,0x12,0x7f,0x55,0x52,0x55,0x0a, + 0xfd,0xff,0xff,0xff,0x3f,0x29,0xe8,0x7f,0xff,0x0f,0x50,0x50,0xff,0xff,0xff, + 0x5f,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x04,0xa9,0x4a,0x25,0x45,0x3e, + 0xa9,0x2a,0xa9,0xa2,0xfc,0xff,0xff,0xff,0x7f,0x55,0xe1,0x7f,0xff,0x27,0x05, + 0xc4,0xff,0xff,0xff,0x9f,0x91,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x41,0x4a, + 0x29,0xa9,0x12,0x5e,0x95,0x94,0x4a,0x0a,0xfe,0xff,0xff,0xff,0xbf,0x12,0xf4, + 0x7f,0xff,0x8f,0x50,0xf1,0xff,0xff,0xff,0xa7,0xc2,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x14,0x92,0xaa,0x4a,0xa2,0xbf,0xa4,0x52,0x95,0x22,0xff,0xff,0xff, + 0xff,0x3f,0x45,0xf2,0x7f,0xff,0x3f,0x04,0xf4,0xff,0xff,0xff,0xd7,0xe8,0xff, + 0xff,0xff,0xff,0x5f,0xff,0xff,0x83,0xa8,0x94,0x54,0x09,0x2f,0x55,0x4a,0x52, + 0x49,0xff,0xff,0xff,0xff,0x5f,0x99,0xf0,0x7f,0xff,0x7f,0x51,0xfc,0xff,0xff, + 0xff,0x6b,0xf1,0xff,0xff,0xff,0xff,0x5f,0xfd,0xff,0x2b,0x2a,0xa9,0x12,0x20, + 0x5f,0xa9,0xaa,0x54,0x00,0xff,0xff,0xff,0xff,0x5f,0x15,0xf2,0x7f,0xff,0xff, + 0x8f,0xff,0xff,0xff,0xff,0x2b,0xfc,0xff,0xff,0xff,0xff,0x2f,0xfd,0xff,0x87, + 0xa0,0x4a,0xaa,0x8a,0x9f,0x4a,0x52,0x15,0xa9,0xff,0xff,0xff,0xff,0x5f,0x8a, + 0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xf8,0xff,0xff,0xff,0xff, + 0x57,0xf2,0xff,0x2f,0x82,0x52,0x05,0xd0,0x2f,0x95,0x4a,0x49,0x84,0xff,0xff, + 0xff,0xff,0xbf,0x24,0xf8,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x12,0xfd, + 0xff,0xff,0xff,0xff,0x4b,0xd5,0xff,0x9f,0x28,0x54,0x48,0xc5,0xbf,0x52,0x55, + 0x0a,0xe1,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfa,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x1a,0xfe,0xff,0xff,0xff,0xff,0x57,0xa9,0xff,0x3f,0x82,0x00,0x21, + 0xf0,0x5f,0x2a,0x49,0x21,0xc4,0xff,0xff,0xff,0xff,0xaf,0x1a,0xfd,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0x3f,0x85,0xff,0xff,0xff,0xff,0xff,0x29,0xa5,0xff, + 0xff,0x24,0x52,0x88,0xfc,0xbf,0x92,0x2a,0x09,0xf1,0xff,0xff,0xff,0xff,0x9f, + 0x4c,0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x15,0xff,0xff,0xff,0x7f, + 0xff,0xa5,0x4a,0xff,0xff,0x90,0x08,0x01,0xfe,0x3f,0x55,0x52,0x24,0xf4,0xff, + 0xff,0xff,0xff,0xaf,0x02,0xfd,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xc6, + 0xff,0xff,0xff,0xbf,0xfe,0x95,0x54,0xff,0xff,0x05,0x42,0xa8,0xfe,0xbf,0xa4, + 0x2a,0x41,0xf9,0xff,0xff,0xff,0xff,0x5f,0x55,0xfc,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0x4f,0xd0,0xff,0xff,0xff,0xbf,0x7c,0xaa,0x92,0xfc,0xff,0x53,0x08, + 0x01,0xff,0x1f,0x4a,0x01,0x04,0xfc,0xff,0xff,0xff,0xff,0x27,0x05,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xc5,0xff,0xff,0xff,0x4f,0xbf,0x52,0xaa, + 0xfe,0xff,0x07,0x42,0xea,0xff,0xbf,0x50,0x54,0x51,0xff,0xff,0xff,0xff,0xff, + 0x97,0x56,0xfe,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xf0,0xff,0xff,0xff, + 0x2f,0x7f,0xa5,0x54,0xfd,0xff,0x3f,0x09,0xe0,0xff,0x1f,0x02,0x01,0x04,0xff, + 0xff,0xff,0xff,0xff,0xaf,0x02,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x4b, + 0xf5,0xff,0xff,0xff,0xab,0x9f,0x94,0x92,0xfc,0xff,0xff,0x40,0xfd,0xff,0x9f, + 0x48,0x48,0xa1,0xff,0xff,0xff,0xff,0xff,0xa7,0x56,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0x6b,0xf8,0xff,0xff,0xff,0xa4,0x5f,0xa9,0x2a,0xfd,0xff,0xff, + 0xff,0xff,0xff,0x3f,0x22,0x21,0xc4,0xff,0xff,0xff,0xff,0xff,0x2f,0x03,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0xfa,0xff,0xff,0x7f,0xd5,0x2f,0xa5, + 0xa4,0xfa,0xff,0xff,0xff,0xff,0xff,0xbf,0x08,0x08,0xf9,0xff,0xff,0xff,0xff, + 0xff,0x97,0x4a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xfc,0xff,0xff, + 0x7f,0x69,0xac,0x2a,0x55,0xf9,0xff,0xff,0xff,0xff,0xff,0x7f,0xa2,0x22,0xf8, + 0xff,0xff,0xff,0xff,0xff,0x53,0x21,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0x15,0xfe,0xff,0xff,0x9f,0x2a,0x95,0x94,0x92,0xf4,0xff,0xff,0xff,0xff,0xff, + 0xff,0x08,0x88,0xfe,0xff,0xff,0xff,0xff,0xff,0x57,0x8b,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xa9,0xfe,0xff,0xff,0x5f,0x52,0xbc,0x52,0x55,0xf5,0xff, + 0xff,0xff,0xff,0xff,0xff,0x21,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xa1, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x7f,0x0d,0xff,0xff,0xff,0x57,0x15,0x3f, + 0x55,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xc8,0xff,0xff,0xff,0xff, + 0xff,0xff,0xd7,0x89,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xbf,0xd6,0xff,0xff, + 0xff,0x4b,0x45,0x3f,0x49,0xaa,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0xf9, + 0xff,0xff,0xff,0xff,0xff,0xff,0xc9,0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0x3f,0x81,0xff,0xff,0xff,0x29,0x11,0x5f,0x28,0x55,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xc8,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0x5f,0xd6,0xff,0xff,0x7f,0xaa,0xc2,0x0f,0x55,0x49,0xea, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5, + 0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x9f,0xe1,0xff,0xff,0xbf,0x4a,0xd1, + 0x5f,0x48,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xe9,0xe0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x27,0xf4,0xff, + 0xff,0xbf,0x94,0xc4,0x07,0x91,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xea,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xaf,0xf1,0xff,0xff,0x9f,0x52,0xe0,0x4b,0x44,0x52,0xe9,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x6a,0xe0,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xab,0x2a,0xf5,0x0f,0x51,0xa5, + 0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x69,0xe5,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x55,0xf8,0xff,0xff,0x95,0x14, + 0xf0,0x5f,0x84,0x54,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x75,0xf0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x13,0xfd, + 0xff,0xff,0xa5,0x42,0xf9,0x7f,0x91,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xb2,0xfa,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0x54,0xfe,0xff,0x7f,0x52,0x12,0xfa,0xff,0x20,0xa5,0xe4,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x34,0xf8,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0x25,0xff,0xff,0xaf,0xaa,0x48,0xfc,0xff,0x0b, + 0x29,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xb5,0xf8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x52,0xff,0xff,0x2f,0x49, + 0x02,0xfe,0xff,0x43,0xaa,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x3f,0x3a,0xfa,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x4a, + 0xff,0xff,0xa5,0x2a,0xa9,0xff,0xff,0x17,0x25,0xe9,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x9a,0xfc,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0x2a,0xff,0x7f,0x95,0x54,0x80,0xff,0xff,0x07,0xa9,0xea,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1d,0xfc, + 0xff,0x7f,0xff,0xff,0xff,0xff,0x3f,0xa9,0xfe,0x7f,0xa9,0x12,0xe5,0xff,0xff, + 0x5f,0x4a,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x5f,0xad,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x95,0xea,0x97,0x54, + 0x4a,0xf0,0xff,0xff,0x1f,0xa8,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x5f,0x0e,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f, + 0x52,0x55,0xa9,0x92,0x02,0xfd,0xff,0xff,0x5f,0x53,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x5e,0xfe,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xbf,0x2a,0x49,0x4a,0x55,0x49,0xfc,0xff,0xff,0x3f,0x94,0xf8, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x0f, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,0xa5,0xaa,0x92,0xa4,0x20,0xff,0xff, + 0xff,0xbf,0xa4,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x5f,0x57,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x52,0x52,0xaa, + 0x2a,0x0a,0xff,0xff,0xff,0x7f,0x54,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0x07,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xa7,0x94,0x4a,0x55,0x4a,0xa0,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0x2f,0x55,0xa9,0x92,0x12,0xe9,0xff,0xff,0xff,0x7f,0x24, + 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf, + 0x87,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0xa5,0x4a,0xaa,0x44,0xf4,0xff, + 0xff,0xff,0xff,0x55,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0xab,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xab,0x94,0xa4, + 0x92,0x12,0xf9,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xab,0x83,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0x47,0xa9,0x2a,0x55,0x40,0xfc,0xff,0xff,0xff,0xff,0x25,0xf5,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff,0xff,0xd7,0x97,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0x33,0x55,0xa9,0x24,0x15,0xfe,0xff,0xff,0xff,0xff, + 0x95,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff, + 0x93,0xc3,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x25,0xa5,0x2a,0x40,0xff, + 0xff,0xff,0xff,0xff,0xa9,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xff, + 0xff,0xff,0xff,0xff,0xe7,0xd5,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4b,0x92, + 0x54,0x92,0xd4,0xff,0xff,0xff,0xff,0xff,0x55,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0xff,0xd5,0xc1,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0x97,0xaa,0x4a,0x05,0xe2,0xff,0xff,0xff,0xff,0xff,0x25,0xf1,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xfd,0xff,0xff,0xff,0xff,0xd5,0xea,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x55,0x25,0xa1,0xf0,0xff,0xff,0xff,0xff, + 0xff,0x95,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe8,0xfa,0xff,0xff,0xff, + 0xff,0xea,0xe0,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xa7,0x24,0x59,0x04,0xfa, + 0xff,0xff,0xff,0xff,0xff,0xa9,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe2, + 0xfd,0xff,0xff,0xff,0xff,0xc9,0xe9,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f, + 0x52,0x05,0xa1,0xfc,0xff,0xff,0xff,0xff,0xff,0xa5,0xfa,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x70,0xf9,0xff,0xff,0xff,0xff,0x74,0xe2,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0x47,0x95,0x92,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xf8, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe2,0xfa,0xff,0xff,0xff,0xff,0x72,0xe8, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x97,0xaa,0x20,0xd0,0xff,0xff,0xff,0xff, + 0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb8,0xfc,0xff,0xff, + 0xff,0xff,0xea,0xe2,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x07,0x04,0x82,0xc2, + 0xff,0xff,0xff,0xff,0xff,0xff,0x29,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x71,0xfd,0xff,0xff,0xff,0x7f,0x2a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0x4f,0x91,0x28,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xff, + 0xff,0xff,0xff,0x1f,0x54,0xfe,0xff,0xff,0xff,0x7f,0x75,0xf2,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0x27,0x44,0x82,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x29, + 0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xb8,0xfc,0xff,0xff,0xff,0xbf,0x14, + 0xf1,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x0f,0x11,0x20,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x9a,0xfe,0xff, + 0xff,0xff,0x7f,0x5a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x40,0x85, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0x2d,0xfd,0xff,0xff,0xff,0x9f,0x12,0xf9,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0x3f,0x14,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfe,0xff,0xff, + 0xff,0xff,0xff,0xff,0x07,0xa6,0xfe,0xff,0xff,0xff,0x5f,0x4d,0xfa,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0x40,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x4b,0xfe,0xff,0xff,0xff,0xbf, + 0x2c,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x43,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x57,0xff, + 0xff,0xff,0xff,0x5f,0x0a,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xd5,0xa9,0xff,0xff,0xff,0xff,0xaf,0x5a,0xfc,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa3,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x81,0x95,0xff,0xff,0xff,0xff,0x9f,0x06,0xfd,0xff, 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xd1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xd4,0xff,0xff,0xff,0xff, - 0x5f,0x55,0xfd,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xc5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf5,0xca, - 0xff,0xff,0xff,0xff,0xaf,0x06,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd1,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xe0,0xe9,0xff,0xff,0xff,0xff,0x97,0x56,0xfe,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc9,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0x74,0xf4,0xff,0xff,0xff,0xff,0x57,0x07,0xff, + 0xff,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xa5,0xff,0xff,0xff,0xff, + 0x2f,0x95,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe0,0xea, + 0xff,0xff,0xff,0xff,0xaf,0x26,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd5,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xf5,0xf4,0xff,0xff,0xff,0xff,0xaf,0x86,0xfe,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc1,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x70,0xe5,0xff,0xff,0xff,0xff,0x4f,0x2e,0xfe, 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xf0,0xfa,0xff,0xff,0xff, - 0xff,0x2f,0x4b,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfb,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xbd, - 0xf2,0xff,0xff,0xff,0xff,0x97,0x12,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xb2,0xfa,0xff,0xff,0xff, + 0xff,0x57,0x83,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x78, + 0xf2,0xff,0xff,0xff,0xff,0xa7,0x22,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x5f,0x38,0xfd,0xff,0xff,0xff,0xff,0xab,0x43,0xff,0xff,0xff,0x7f, + 0xff,0xff,0x5f,0x5d,0xfd,0xff,0xff,0xff,0xff,0x97,0x87,0xff,0xff,0xff,0x7f, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x5d,0xfd,0xff,0xff,0xff,0xff,0x4b,0x93, + 0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x3c,0xfd,0xff,0xff,0xff,0xff,0x53,0xa3, 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x5c,0xfe,0xff,0xff, - 0xff,0xff,0x57,0xc5,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xac,0xfe,0xff,0xff, + 0xff,0xff,0x57,0x95,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f, - 0xaf,0xfe,0xff,0xff,0xff,0xff,0xa7,0x91,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0x9e,0xfe,0xff,0xff,0xff,0xff,0x97,0x81,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x27,0x4f,0xff,0xff,0xff,0xff,0xff,0x49,0x85,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x57,0xfe,0xff,0xff,0xff,0xff,0xa9,0xa5,0xff,0xff,0xff, 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x43,0x2f,0xff,0xff,0xff,0xff,0xff,0xab, - 0xa1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x8b,0x53,0xff,0xff, - 0xff,0xff,0xff,0x95,0x8a,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0xaf,0xff,0xff,0xff,0xff,0xff,0x4b, + 0x89,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x93,0xff,0xff, + 0xff,0xff,0xff,0x95,0xa2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xa3,0xcb,0xff,0xff,0xff,0xff,0xff,0xd3,0xe0,0xff,0xff,0xff,0x7f,0xff,0xff, + 0x83,0xab,0xff,0xff,0xff,0xff,0xff,0xd3,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xff, - 0xff,0xff,0xff,0xff,0xc9,0xd5,0xff,0xff,0xff,0xff,0xff,0xd5,0xc2,0xff,0xff, + 0xff,0xff,0xff,0xff,0xe9,0xa5,0xff,0xff,0xff,0xff,0xff,0xa5,0xe1,0xff,0xff, 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xd5,0xff,0xff,0xff,0xff,0xff, - 0xaa,0xd0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xea,0xd2,0xff, - 0xff,0xff,0xff,0xff,0x51,0xc5,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xd5,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xea,0xea,0xff, + 0xff,0xff,0xff,0xff,0x14,0xc1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff, - 0xff,0x60,0xe9,0xff,0xff,0xff,0xff,0xff,0x54,0xe0,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xe0,0xe4,0xff,0xff,0xff,0xff,0xff,0x65,0xe8,0xff,0xff,0xff,0x7f,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf, - 0xff,0xff,0xff,0xff,0x3f,0xfa,0xea,0xff,0xff,0xff,0xff,0xff,0x65,0xe5,0xff, + 0xff,0xff,0xff,0xff,0x3f,0x72,0xe9,0xff,0xff,0xff,0xff,0xff,0x6a,0xe1,0xff, 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xbf,0x70,0xf5,0xff,0xff,0xff,0xff, - 0x7f,0x55,0xe8,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0x1f,0x3a,0xf9, - 0xff,0xff,0xff,0xff,0xff,0x54,0xe2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xbf,0xb8,0xfa,0xff,0xff,0xff,0xff, + 0xff,0x52,0xea,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0x1f,0x7a,0xf5, + 0xff,0xff,0xff,0xff,0x7f,0x2a,0xe0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff, - 0xff,0x8f,0xb8,0xfc,0xff,0xff,0xff,0xff,0x7f,0x92,0xf0,0xff,0xff,0xff,0x7f, + 0xff,0x8f,0x58,0xfa,0xff,0xff,0xff,0xff,0x7f,0x25,0xf5,0xff,0xff,0xff,0x7f, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xb5,0xff,0xff,0xdf,0xff,0x57,0x5e,0xfd,0xff,0xff,0xff,0xff,0xff,0x2a,0xe2, + 0xb5,0xff,0xff,0xdf,0xff,0x57,0x5e,0xfd,0xff,0xff,0xff,0xff,0xff,0x34,0xe0, 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xca,0xff,0xff,0x8f,0xff,0x07,0x2c,0xfd,0xff,0xff,0xff, - 0xff,0xff,0x6a,0xf4,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe9,0xff,0xff,0x57,0xff,0x2b,0xad, - 0xfe,0xff,0xff,0xff,0xff,0x7f,0x29,0xf1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xff,0xff, - 0x07,0xff,0x43,0x92,0xfe,0xff,0xff,0xff,0xff,0x7f,0x6a,0xf8,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xca,0xff,0xff,0x8f,0xff,0x07,0xac,0xfc,0xff,0xff,0xff, + 0xff,0x7f,0x2a,0xf5,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd4,0xff,0xff,0x57,0xff,0x2b,0x2d, + 0xfd,0xff,0xff,0xff,0xff,0xff,0xb2,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd2,0xff,0xff, + 0x07,0xff,0x43,0x4a,0xff,0xff,0xff,0xff,0xff,0xbf,0x2a,0xf8,0xff,0xff,0xff, 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x3f,0xd5,0xff,0xff,0x2b,0xfe,0x08,0x57,0xfe,0xff,0xff,0xff,0xff,0xbf,0x0a, - 0xf1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xdf,0xc4,0xff,0xff,0x83,0x36,0x42,0xa5,0xff,0xff,0xff, - 0xff,0xff,0x7f,0x55,0xf4,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,0x48,0x4a,0x88, - 0x49,0xff,0xff,0xff,0xff,0xff,0x3f,0x19,0xf9,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xe5,0xff, - 0x7f,0x10,0x29,0xa2,0xb4,0xff,0xff,0xff,0xff,0xff,0xbf,0x54,0xf8,0xff,0xff, + 0x3f,0xc5,0xff,0xff,0x2b,0xfe,0x08,0xab,0xfe,0xff,0xff,0xff,0xff,0x7f,0xaa, + 0xf2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xbf,0xea,0xff,0xff,0x83,0x36,0x20,0x55,0xff,0xff,0xff, + 0xff,0xff,0x3f,0x15,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xc2,0xff,0xff,0x48,0x4a,0x85, + 0x49,0xff,0xff,0xff,0xff,0xff,0x7f,0x59,0xfa,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xf5,0xff, + 0x7f,0x10,0x29,0x50,0xa5,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xf9,0xff,0xff, 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xa7,0xf4,0xff,0x7f,0x05,0x95,0x48,0xc5,0xff,0xff,0xff,0xff,0xff,0x7f, - 0x15,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x57,0xe2,0xff,0xbf,0xa0,0x24,0x42,0xd5,0xff,0xff, - 0xff,0xff,0xff,0xbf,0xba,0xf8,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xe5,0xff,0x3f,0x92,0xaa, - 0xa8,0xf4,0xff,0xff,0xff,0xff,0xff,0x5f,0x0a,0xfa,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xe9, - 0xff,0x9f,0xa0,0x2a,0x55,0xea,0xff,0xff,0xff,0xff,0xff,0x5f,0x8d,0xf8,0xff, + 0xff,0x97,0xe4,0xff,0x7f,0x05,0x95,0x42,0xd5,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x35,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xab,0xea,0xff,0xbf,0xa0,0x24,0xa8,0xd4,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x19,0xf9,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x27,0xe5,0xff,0x3f,0x92,0xaa, + 0x50,0xe9,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0xe2, + 0xff,0x9f,0xa0,0xaa,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xf9,0xff, 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x92,0xf0,0xff,0x5f,0x4a,0x52,0xa9,0xf2,0xff,0xff,0xff,0xff,0xff, - 0x3f,0x19,0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0x55,0xf5,0xff,0x1f,0x20,0x29,0x25,0xfd,0xff, - 0xff,0xff,0xff,0xff,0x5f,0x8d,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0xf8,0xff,0x47,0xa9, - 0x4a,0x55,0xfa,0xff,0xff,0xff,0xff,0xff,0x5f,0x2a,0xfe,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x92, - 0xf2,0xff,0x17,0x52,0x55,0x49,0xfd,0xff,0xff,0xff,0xff,0xff,0x5f,0x8d,0xfc, + 0xff,0xff,0x95,0xf8,0xff,0x5f,0x4a,0x92,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xbf,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xf2,0xff,0x1f,0x20,0x49,0xa5,0xfa,0xff, + 0xff,0xff,0xff,0xff,0x5f,0x1a,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaa,0xf8,0xff,0x47,0xa9, + 0x2a,0x29,0xf9,0xff,0xff,0xff,0xff,0xff,0xbf,0x0a,0xfc,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49, + 0xf2,0xff,0x17,0x92,0xaa,0xaa,0xfe,0xff,0xff,0xff,0xff,0xff,0x9f,0xac,0xfe, 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x9f,0x54,0xf8,0xff,0x43,0x48,0x92,0xaa,0xfe,0xff,0xff,0xff,0xff, - 0xff,0xaf,0x2c,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x2a,0xfa,0xff,0x11,0x2a,0x55,0x52,0xff, - 0xff,0xff,0xff,0xff,0xff,0x4f,0x06,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x92,0xfc,0xff,0x43, - 0x52,0xa9,0x4a,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x55,0xfc,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f, - 0x09,0xfe,0xff,0x14,0xa9,0x4a,0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0x06, + 0xff,0xff,0x9f,0x2a,0xf8,0xff,0x43,0xa8,0x24,0x25,0xff,0xff,0xff,0xff,0xff, + 0xff,0xaf,0x0a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xfa,0xff,0x91,0x54,0xaa,0x52,0xff, + 0xff,0xff,0xff,0xff,0xff,0x2f,0x4d,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x45,0xfc,0xff,0x03, + 0x92,0x52,0xaa,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x06,0xfc,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf, + 0x12,0xfe,0xff,0x50,0xaa,0x2a,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xa5, 0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x57,0xa5,0xfe,0xff,0x40,0x4a,0x92,0xaa,0xff,0xff,0xff,0xff, - 0xff,0xff,0x4f,0x56,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x0a,0xff,0x7f,0x92,0x2a,0x55,0xd2, - 0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x05,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xa0,0xff,0x7f, - 0x89,0x54,0x55,0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x4d,0xfc,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x44,0xff,0xff,0x0a,0x25,0xa5,0xa4,0xff,0xff,0xff,0xff, + 0xff,0xff,0x97,0x06,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x15,0xff,0xff,0x40,0xa9,0x92,0xea, + 0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x55,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xa1,0xff,0x7f, + 0x92,0x4a,0xaa,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x06,0xfc,0xff,0xff, 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x52,0x8b,0xff,0x7f,0x80,0x92,0x92,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0x97, - 0x16,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x55,0xe0,0xff,0x3f,0x55,0x55,0x2a,0xe9,0xff,0xff,0xff, - 0xff,0xff,0xff,0x57,0x47,0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xea,0xff,0x1f,0xa0,0xa4,0x52, - 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x02,0xfe,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xa5,0xf0,0xff, - 0x5f,0x49,0xb5,0xa4,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0xab,0xff,0xff, + 0x95,0x8a,0xff,0x3f,0x84,0x54,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0x2f, + 0x25,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x52,0xe0,0xff,0xbf,0x50,0xa9,0x4a,0xf2,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x8e,0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa9,0xea,0xff,0x3f,0x24,0x95,0x54, + 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x23,0xfe,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x4a,0xf0,0xff, + 0x9f,0x50,0x69,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x8b,0xff,0xff, 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xbf,0x52,0xf4,0xff,0x1f,0xaa,0xf4,0x2a,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, - 0x4f,0x03,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xbf,0x2a,0xf8,0xff,0x4f,0x28,0xfd,0xaa,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xff,0xd7,0xab,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0x94,0xfe,0xff,0x07,0x55,0xfd, - 0x49,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x83,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x12,0xfc, - 0xff,0x17,0xa6,0xfe,0xeb,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xcf,0xff, + 0x7f,0xa5,0xf4,0xff,0x0f,0x2d,0x75,0xaa,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xaf,0x03,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9f,0x14,0xfa,0xff,0x2f,0xa8,0xfa,0x25,0xfd,0xff,0xff, + 0xff,0xff,0xff,0xff,0x97,0xd7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xaa,0xfc,0xff,0x0f,0x4d,0xfd, + 0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf,0x83,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x12,0xfc, + 0xff,0x27,0x92,0xfe,0xcb,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd7,0xd7,0xff, 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x57,0x8a,0xfe,0xff,0xa3,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xd7,0xe7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x4b,0x25,0xff,0xff,0x07,0x4a,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xef,0xe7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x02,0xff,0xff,0x51,0x53, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xd4, - 0xff,0xff,0x05,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7, + 0xff,0x97,0x0a,0xff,0xff,0x83,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xef,0xc7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xab,0x24,0xff,0xff,0x2b,0xaa,0xfe,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xe7,0xef,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0x05,0x95, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x82, + 0xff,0xff,0x51,0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7, 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x49,0xc1,0xff,0xff,0xa1,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0x2a,0xc9,0xff,0xff,0x92,0xea,0xff,0xff,0xff, + 0xff,0xff,0xa9,0xe8,0xff,0xff,0x85,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xc1,0xff,0xff,0x90,0xd5,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xe2,0xff,0xff,0x04, - 0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x55, - 0xf8,0xff,0x7f,0xd1,0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x4d,0xe8,0xff,0xff,0xa5, + 0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x51, + 0xf2,0xff,0x7f,0x40,0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x3f,0x29,0xf8,0xff,0x7f,0x84,0xea,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x3f,0x95,0xf8,0xff,0x7f,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xa5,0xfa,0xff,0xbf,0x70,0xe9,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x15,0xfa,0xff,0x3f,0xa4,0xf4,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x14,0xfc,0xff,0x3f, - 0xb4,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf, - 0x4a,0xfe,0xff,0x7f,0x51,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xa4,0xfc,0xff,0x7f, + 0x71,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f, + 0x15,0xfe,0xff,0x3f,0x94,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x27,0x09,0xff,0xff,0x1f,0x38,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x0a,0xff,0xff,0x1f,0x79,0xf2,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x22,0xff,0xff,0xbf,0x5a,0xfa,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xa4,0xff,0xff,0x5f,0x8c,0xfa,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x89,0xff,0xff, - 0x1f,0x4c,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x82,0xff,0xff, + 0x1f,0x5c,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x24,0xa5,0xff,0xff,0x5f,0xae,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xa4,0x92,0xff,0xff,0xbf,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x55,0xc1,0xff,0xff,0x1f,0x57,0xfe,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9a,0xc4,0xff,0xff,0x0f,0x2e,0xfd,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x95,0xf4,0xff,0xff,0x4f,0x4f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa2,0xf0,0xff,0xff,0xaf,0xa7,0xfe, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x52,0xe0,0xff, - 0xff,0x0f,0xa7,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x55,0xe4,0xff, + 0xff,0x0f,0x57,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x5f,0x2a,0xf9,0xff,0xff,0xaf,0x2b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xbf,0x54,0xf2,0xff,0xff,0x9f,0x4b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xbf,0x92,0xf8,0xff,0xff,0x8f,0xd7,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9f,0x92,0xf8,0xff,0xff,0xc7,0xab,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x25,0xfe,0xff,0xff,0xa7,0xd3, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x15,0xfe,0xff,0xff,0x97,0xd7, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x94,0xfc, - 0xff,0xff,0xc7,0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0x94,0xfc, + 0xff,0xff,0xc7,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x97,0x0a,0xfe,0xff,0xff,0xcf,0xeb,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x2f,0x05,0xfe,0xff,0xff,0xcf,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x57,0x89,0xff,0xff,0xff,0xe3,0xf3,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x53,0xa9,0xff,0xff,0xff,0xd3,0xeb,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x29,0x25,0xff,0xff,0xff,0xeb, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x05,0xff,0xff,0xff,0xe3, 0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x82, - 0xff,0xff,0xff,0xe3,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0xc2, + 0xff,0xff,0xff,0xeb,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x52,0xe8,0xff,0xff,0xff,0xf7,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x95,0xc8,0xff,0xff,0xff,0xf3,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0xc3,0xff,0xff,0xff,0xfb,0xf4,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xd2,0xff,0xff,0xff,0xff,0xf5,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xa9,0xe8,0xff,0xff,0xff, - 0xff,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x54, - 0xf0,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xaa,0xe0,0xff,0xff,0xff, + 0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49, + 0xf8,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xbf,0x4a,0xfa,0xff,0xff,0xff,0xff,0xf9,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x9f,0x2a,0xf5,0xff,0xff,0xff,0xff,0xfd,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x25,0xf8,0xff,0xff,0xff,0xff,0xfe,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x4a,0xf8,0xff,0xff,0xff,0xff,0xfc,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x14,0xfd,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0x94,0xfe,0xff,0xff, - 0xff,0xff,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57, - 0x15,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97, + 0x4a,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xa7,0x44,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xab,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x12,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x52,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0xc2,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x85,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x2a,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x54,0xa2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x52,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x4a,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xf0,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xe0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x55,0xe2,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xe4,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x5f,0xa5,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x5f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xbf,0x14,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xbf,0x12,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xa5,0xf8,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x54,0xfa,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x09,0xfe, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x0a,0xfc, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x2b,0x95,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x53,0x45,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xa7,0x0a,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x97,0x14,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x42,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0x89, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0x82, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xa5,0xe2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x4a,0xe9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0x2a,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x52,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xe0,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x55,0xe8,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x29, - 0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24, + 0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xbf,0xaa,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x95,0xfc,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xfe,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f, - 0x09,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f, + 0x49,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x4f,0x95,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x2f,0x95,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x42,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x01,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x95,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x27,0x81,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x57,0x81,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xaf,0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x97,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0xf1,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xe0,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xe4,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x93,0xf4,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x97,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x57,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x25,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x2b,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xf8,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xfc,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0xfe, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfc, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x84,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x05,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x49,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x81,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x22,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaa, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x89, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, - 0xff,0xff,0x7f,0xc2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xd1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xe1,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xe9,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, - 0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, - 0xff,0xff,0xff,0x9f,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x9f,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf8,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfd,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfc,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, - 0x6f,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x6f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, 0xff,0xff,0xff,0xff,0xbf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, diff -r 498bf5da1c90 -r 0d2f883870bc etc/sounds/README --- a/etc/sounds/README Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/sounds/README Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,9 @@ This directory contains some mu-law encoded SunOS 4.1 sound files. -If you're running XEmacs on the console of a SparcStation or SGI -machine, you can use these sounds to replace the default beep. See the +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +You can use these sounds to replace the default beep. See the documentation of the `sound-alist' variable, and the functions `load-default-sounds' and `load-sound-file' from lisp/prim/sound.el. diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/help-up.xpm --- a/etc/vm/help-up.xpm Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/vm/help-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -3,7 +3,7 @@ "64 42 6 1", "X c Gray75 s backgroundToolBarColor", "i c Gray20", -"@ c yellow", +"@ c rgb:00/df/ff", "T c red", "t c pink", "o c black", diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-colorful-dn.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-colorful-dn.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,137 @@ +/* XPM */ +static char *mime-colorful-dn[] = { +/* width height num_colors chars_per_pixel */ +" 64 42 88 2", +/* colors */ +".. c #878787", +".# c #818181", +".a c #7f7f7f", +".b c #939393", +".c c #969696", +".d c #979797", +".e c #9f9f9f", +".f c #a7a7a7", +".g c #a1a1a1", +".h c #a5a5a5", +".i c #aeaeae", +".j c #adadad", +".k c #959595", +".l c #9a9a9a", +".m c #939393", +".n c #868686", +".o c #828282", +".p c #8b8b8b", +".q c #a3a3a3", +".r c #838383", +".s c #8e8e8e", +".t c #a2a2a2", +".u c #7d7d7d", +".v c #7b7b7b", +".w c #797979", +".x c #767676", +".y c #757575", +".z c #757575", +".A c #777777", +".B c #727272", +".C c #6f6f6f", +".D c #6a6a6a", +".E c #636363", +".F c #6b6b6b", +".G c #8a8a8a", +".H c #8e8e8e", +".I c #676767", +".J c #6e6e6e", +".K c #7a7a7a", +".L c #626262", +".M c #7e7e7e", +".N c #8d8d8d", +".O c #565656", +".P c #505050", +".Q c #4d4d4d", +".R c #494949", +".S c #434343", +".T c #404040", +".U c #575757", +".V c #393939", +".W c #3d3d3d", +".X c #3f3f3f", +".Y c #4f4f4f", +".Z c #585858", +".0 c #5b5b5b", +".1 c #5a5a5a", +".2 c #858585", +".3 c #5e5e5e", +".4 c #4b4b4b", +".5 c #7b7b7b", +".6 c #3a3a3a", +".7 c #636363", +".8 c #444444", +".9 c #3c3c3c", +"#. c #353535", +"## c #515151", +"#a c #323232", +"#b c #6c6c6c", +"#c c #6a6a6a", +"#d c #6f6f6f", +"#e c #2a2a2a", +"#f c #666666", +"#g c #838383", +"#h c #2d2d2d", +"#i c #737373", +"#j c #8f8f8f", +"#k c #6c6c6c", +"#l c #a3a3a3", +"#m c #9f9f9f", +"#n c Gray60", +"#o c #969696", +"#p c #b0b0b0", +"#q c #ababab", +"#r c #9e9e9e", +"#s c #9a9a9a", +"#t c #8a8a8a", +"#u c Gray60", +"#v c #a7a7a7", +/* pixels */ +"...#.#.......a.a.#.....b.b.c.d.d.d.e.d.e.e.e.e.e.e.f.g.g.h.h.e.f.h.i.h.h.f.h.h.f.h.j.j.f.h.f.j.f.h.j.h.j.h.g.e.e.e.d.d.k.c.l.b.m", +".b.n...........o...p.b.b.b.b.c.d.d.e.c.d.e.e.e.d.g.e.e.e.g.l.g.e.e.g.g.e.g.q.f.h.h.h.g.h.h.h.j.i.h.h.h.h.e.e.e.e.l.e.c.d.e.c.m.c", +".r.r...#...........b.b.b.s.b.m.d.d.c.l.e.d.l.e.d.e.m.d.l.d.e.e.e.e.e.e.e.e.d.g.d.e.e.e.h.g.f.h.h.h.h.f.h.g.t.e.e.d.e.d.c.c.d.c.c", +".#.o.a.#.#.#...#.......p...b.b.b.m.k.d.b.d.d.m.b.b.d.d.b.b.b.m.k.d.d.d.d.d.b.m.k.d.d.d.d.g.g.g.e.e.g.e.g.e.e.d.d.d.d.d.b.k.b.b.d", +".s.......#.#.#...#.o.#.....#.....p.....p.......#.a.#.#.......#.............b.b.b...b.b.k.e.c.e.d.e.d.e.d.e.e.d.d.k.c.b.b.m.b.m.d", +".#.#.o.r.a.u.a.u.o.u.u.u.a.#.o.u.u.r.u.u.u.v.u.w.w.x.u.u.u.u.u.u.a.#.o.#.o.............s.s.b.k.k.k.b.k.b.m.b.b.s.......s...b.s.b", +"...a.u.u.w.u.u.y.w.z.z.u.u.u.z.u.w.z.y.z.z.u.z.z.z.z.z.y.u.w.u.z.#.a.u.#.a.#.#.#...#.....#...........p.b.b...#.o.o.a.o.o.#.s.s.s", +".a.w.z.u.w.z.w.w.w.z.A.u.z.z.z.B.z.z.A.z.A.z.A.y.z.C.A.z.z.y.w.w.w.a.o.a.#.#.o.a.o...o...#...#.#.#.#.r.#.#...o.a.a.o.u.a.o.o.#..", +".#.o.u.z.z.z.z.B.B.z.y.B.z.B.B.B.B.B.B.B.B.B.B.B.C.B.B.w.w.w.w.x.u.w.u.u.o...a...#.....#.#...n.#.#.#.n...#.#.o.#.#.....#.o.r.#.#", +".w.a.w.w.B.B.B.z.B.B.z.B.B.D.C.B.C.B.B.C.D.C.E.C.C.F.z.B.B.B.w.B.u.u.u.u.u.#.#.#.....G.......H...#.#.#.........#.....H..........", +".w.x.z.z.B.B.z.C.z.B.B.B.C.C.D.C.E.I.C.E.E.D.D.C.B.F.B.B.F.z.w.w.w.u.#.v.o.a...........G...G...b.s.H.s.H.....G.s.H...G.b.s......", +".w.x.z.B.B.z.A.z.B.B.B.F.C.B.F.E.C.E.E.C.E.F.E.B.J.B.B.B.w.w.w.w.w.o.u.#.o.#.#...n.#.....s...p.s.b...b.b...G.b...G.b...p.b...G..", +".w.w.w.x.B.#.B.w.B.F.B.B.F.D.B.D.B.D.D.I.F.E.C.D.B.B.F.z.z.z.B.w.z.w.o.K.u.#.o.w.o.n...#.G.....H.b...s.G.b.b.s.H.p.b.b.s...G...#", +".u.w.w.w.w.w.w.K.u.z.B.B.B.F.B.B.C.D.C.E.F.L.E.L.L.I.E.F.C.C.B.F.B.C.C.z.z.u.M.w.a.o.a.#.....H...s.G.b.b.N...b.....p...s.G.N...#", +".a.w.a.w.a.o.a.u.y.w.B.B.B.B.C.E.L.O.P.P.Q.R.S.S.T.Q.R.R.R.P.P.U.O.L.L.L.E.B.F.B.B.x.w.M.w.#.o.o.#.#.......s.....s.s.G...s......", +".#...o...o.r.a.#.u.u.B.C.F.E.P.U.R.V.P.R.V.W.T.V.V.X.S.S.T.Q.R.P.Y.Z.0.1.Z.1.L.1.E.L.B.B.B.x.w.w.o.2...#...G...#.n.s...G.....#..", +".....#...#.o.r.a.w.w.B.F.3.P.Z.4.R.R.Q.V.S.S.T.W.V.S.V.S.V.S.S.W.R.P.Z.U.L.0.0.L.0.U.L.E.F.C.z.w.a.5.#.#.o.#...#...n.o.#...o....", +".........#.o.a.o.x.x.C.O.Z.U.R.Y.R.R.R.W.W.S.S.W.W.V.6.6.W.S.W.W.R.S.W.R.S.R.P.Z.L.L.L.0.0.0.7.F.B.x.w.w.K.o.o.o.o...n.....n....", +".s.H.......o.a.w.x.F.U.Z.U.Y.P.R.Y.R.S.S.8.R.6.S.S.6.S.W.6.9.9.9.9#..9#..6.S.R.Y.U.Z.P##.L.L.0.L.0.F.F.B.x.x.M.o.5...n.n.o...G..", +".b.s.H...#.n.K.x.F.1.L.L.P.P.4.Y.R.8.Z.Y.L.Z.V.W.R.S.W#..9#.#..6.S.8.8.W.6.W.R.R.R.R.R.Z.L.L.F.L.L.U.0.F.F.M.w.M.o.n.2...o......", +".s.s...n.#.o.w.F.L.L.L.1.L.L.U.Z.Z.Z.Z.5.7.R.S.S.R.S.9#a.9#.#.#b#b#c.Z.R.W.S.S.Y.R.Y.R.Y.Y.U.7.L.L.F.L.E.F.F.M.M.w.M.o.n.....G.s", +".s.G.....o.K.M.1.F.F.E.F.L.L.Z#d.o.K.n.n.7.Z.Z.Y.S.W#a#e#a#e.6#d#d.5#b.R.8.S.Y#d.Z.R.R.R.8.Z.Z.U.7.F.B#d.C.B.x.A.#.o.a...G.H.b.k", +".s.N.G...o.5.B.F.C.C.3.F.F#f#d.n.K.o.n#g#c.Z.Z.Z.S.6#.#e#h#..8#d.5#g.5.Z.8.Y.U.5.5#c.Y.Y.Y.R.Y.L.L.F.F.B.x.F.A.x.5..#g.....b.k.k", +".H.s...n.o.w.C.F.B.C.C.F#f.M.o#g.n.n.H.G.5#d.U.Y.Y.6#.#a#.#..6#d#b.5#d.Z.Y.Z.7#g.n.5#d.Z.R.Y.Y.P.L.7.F.F.B.o.K.#.o.n...G.H.b.H.d", +".s.H.....#.w.B.B#i.F#d.B.o.n.n.H.H.n.H#j.5.Z.Z.Z.L.U.Z.Y.6#..W.7#d.7#d.Z.7.7#d.H#j.H.G.5.Z.U.4.Z.Z.L.L#k.A.w.5.o.....G.m.b.k.b.k", +".s.H...n.#.w.w.x.B.z.B.5.5.n#g.n.n.H#j.H#g#c.L.L#d#d#d.7.Y.R.W.Y.7#d.7.Y.Z#c.n#l#m.G#m.H.A.7.F.L.0.L.C.A.B.F.o.....G.b.H.k.d.d.g", +".k.H.....n.#.o.w#n#n#n#n#n.n.n.n.H#m.k#o.H.5#c#c#b#b#c#d#d#d#d.7#b#b#d#c#d#d#p#q#l#n#n.5.A.x.M.M.A.A#d.F#d.#.N.G.b.k.k.k.d.g.k.g", +".b.H.G...n.#.o.5#n#n.B.x#n#n.n.H.k#r.k.t.t.H#d#c#b#b#d#d#c.5#d#d#d#d#d#b#d#l#p.t#q#n#n.M.M.M.M.M.M.o.G.H.G.H.b.k.k.k.d.g#s.d.g#m", +".H.k.H.H...o.n#n#n.B.B.B#n#n.n.G#n#n#n#n.t#m#g#n#n#n#n#d#d#d#n#n#n#n#d#d#r#n#n#l#n#n.5.5#n#n#n#n.M.5.n.b.k.k.k.k.g.b#m.b.g.g.g.k", +".d#m.b.k.#.o.o#n#n.x.B.B#n#n.n#n#n.k#l#n#n#p#n#n#d#d#n#n#d#n#n#d#b#n#n.k#n#n#q#n#n#n.n#n#n.M.M#n.o.n.s.G.b.k.g.k.b#m.k.g.g#r.g.k", +".b.k.b.k...o#n#n.o.w.B.B#n#n#n#n.G.k#r#n#n#n#n#r.5.5#b#d#n#n#b#d#d#n#n#n#n#p#r.H#n#n#n#n.M.A#g#n.o.n.H.H.d#m.d.g.g.g.g.g.e.g.g.g", +".k.d.g.k.H.o#n#n.w.B.w#n#n.M#n#n#n#n#n#n#r#n#n#l.t#m.H#g#n#n.5.H#n#n#p#n#n#m.G#n#n#t#n#n#n#n#n#n.H.k.H.k.d.g#m.g.g.g.g.g.h.g.g.g", +".g.e.d.d.H.o#n#n.x.w.w#n#n#n#n.o#g.n.o#g#n#n.s#m#r#n#n#n#n#m#m#u#u#n#n#n#m.G#u#u#n#u#u.n#u#u.n.n.H.H.k#u#u.e#u#u#u#u#u.g.h.h.f.h", +".e.k.g.k.b#n#n.M.M.M#n#n.5#n#n.a.o#n#n.n#n#n.G.H#n#n.s#n#n.H.H#u#u#u#n#n.N#u#u#u#j#u#u.N#u#u#u.H.H.b#u#u#u.g#u#u.h.h.g#q.h#q.h.h", +".e#m.d.d.b#n#n#n#n#n#n.o.w.M#n#n#n#n.w.5.##n#n#n#n.H.H.G#n#n#n#u#u#u.G#n#n#u#u#u.H#u#u#n#u#u#u.k.k.H#u#u#u.g#u#u.g.h.h.h.h.i.h.g", +".d.g.g.k.d.k.p.s...#...n.5.5.#.5.M.A.M.#.5.o...5.n.G...n#g.G#g#u#u#u#u.n#u#u#u#u.k#u#u.b#u#u#u#u.g#u#u#u#u.h#u#u#u#u#u.h#v.f.f#q", +".g.g.g.g.d.d.b.G.H...G.....n.o.o.A.o.s.M.#.n.5.o.o.n.o#g.x.n.n#u#u.b#u.G#u.k#u#u.H#u#u.g#u#u.g#u.g#u.h#u#u.i#u#u.i.g.i.f.i.g.h.i", +".g.t.g.g.d.e.k.b.H.H.G.H.G.....5.o.n.o.5...5.G.o.n.....G.M.G..#u#u.d#u#u#u#m#u#u.k#u#u.g#u#u.g#u#u#u.h#u#u.h#u#u.h#q.f#q.h.i.h.j", +".t.h.h.g.g#r.d.d.H.s.H.b.H.H.G.G.......n.G...G.n.G.H.H.H.n.H.H#u#u.g#m#u.g#m#u#u#r#u#u#r#u#u.h#q#u#q.h#u#u.i#u#u#q.h#q.h.i#q.i.h", +".g.t.h.g.g.g.k.d.k.b.H.b.H.k.b.H.G.s.n.H.G.H.H.s.H.k.d.k.s.H.H#u#u#m#m#u#s#m#u#u#m#u#u#m#u#u#q.g#u.g#q#u#u.i#u#u#u#u#u#q.h.i.h#q", +".h.h#v.h.g.g.g#m.d.d.k.d.k.k.k.d.H.k.G.s.H.b.b.k.b.d.b.H.e#m.H.k.g#m#m.g#r.g.g#q.g.h#q.h#q.g#q.h#q#q.h.i.i.h.i.i.i.i.h.i.h.i.h.f", +".g.g.h.f.h.g.g.e.d.g.b.k.d.k.b.k.k.k.d.b.b.k.k.k.d.d.d.g.k.g.k.g#r.g.g.g.t.g.h#q#m.h#v#q.h#q.h#q#q#q.i#q.i.h.h#q.h.i.h.i.h.f.i.h" +}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-colorful-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-colorful-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,133 @@ +/* XPM */ +static char * mime-fancy-up_xpm[] = { +"64 42 88 1", +" c #B8B878785050", +". c #B0B070705050", +"X c #B0B070704848", +"o c #C8C880806060", +"O c #C8C888885858", +"+ c #C8C888886060", +"@ c #D0D090906868", +"# c #D8D898987070", +"$ c #D0D090907070", +"% c #D0D098987070", +"& c #D8D8A0A08080", +"* c #D8D8A0A07878", +"= c #C0C088886060", +"- c #D0D088886060", +"; c #C0C088885858", +": c #B0B078785858", +"> c #B0B070705858", +", c #C0C078785858", +"< c #D0D098986868", +"1 c #B8B870705050", +"2 c #C0C080805050", +"3 c #C8C898987070", +"4 c #A8A870704848", +"5 c #B0B068684848", +"6 c #A8A868684848", +"7 c #A0A068684848", +"8 c #A8A860604848", +"9 c #A0A068684040", +"0 c #A0A068685050", +"q c #A0A060604848", +"w c #989860604848", +"e c #989858584040", +"r c #909050504040", +"t c #909060604040", +"y c #B8B878786060", +"u c #B8B880806060", +"i c #909058584040", +"p c #989860604040", +"a c #A0A070704848", +"s c #808058584040", +"d c #A8A870705050", +"f c #B8B880805858", +"g c #787848483838", +"h c #686848483838", +"j c #686840404040", +"k c #606040403838", +"l c #585838383838", +"z c #505038383838", +"x c #787848484040", +"c c #484830303838", +"v c #484838383838", +"b c #505038383030", +"n c #606048484040", +"m c #707050504040", +"M c #787850504040", +"N c #808048484040", +"B c #B0B078785050", +"V c #808050504040", +"C c #606040404040", +"Z c #A0A070705050", +"A c #404038383838", +"S c #808058584848", +"D c #505040403838", +"F c #484838383030", +"G c #404030303030", +"H c #686848484040", +"J c #383830303030", +"K c #808068685050", +"L c #888860604848", +"P c #888868685050", +"I c #303028282828", +"U c #888858584848", +"Y c #A8A878785858", +"T c #383828282828", +"R c #989868684848", +"E c #B8B880806868", +"W c #909060604848", +"Q c #C8C898987878", +"! c #C8C890907878", +"~ c #FFFFFFFFFFFF", +"^ c #C0C088886868", +"/ c #D0D0A8A88888", +"( c #D0D0A0A08080", +") c #C8C890907070", +"_ c #C8C888887070", +"` c #B0B080805858", +"' c #000000000000", +"] c #D0D098988080", +" .. XX. ooO+++@+@@@@@@#$$%%@#%&%%#%%#%**#%#*#%*%*%$@@@++=O-o;", +"o: > ,ooooO++@O+@@@+$@@@$-$@@$$@$<#%%%$%%%*&%%%%@@@@-@O+@O;O", +"11 . ooo2o;++O-@+-@+@;+-+@@@@@@@@+$+@@@%$#%%%%#%$3@@+@+OO+OO", +".>X... . , ooo;=+o++;oo++ooo;=+++++o;=++++$$$@@$@$@@+++++o=oo+", +"2 ... .>. . , , .X.. . ooo oo=@O@+@+@+@@++=Ooo;o;+", +"..>1X4X4>444X.>44144454667444444X.>.> 22o===o=o;oo2 2 o2o", +" X446448699444946989949999984649.X4.X... . . ,oo .>>X>>.222", +"X69469666904999q990909089w0998666X>X..>X> > . ....1.. >XX>4X>>. ", +".>49999qq98q9qqqqqqqqqqqwqq666674644> X . .. :...: ..>.. .>1..", +"6X66qqq9qq9qqewqwqqwewrwwt9qqq6q44444... y u ... . u ", +"6799qq9w9qqqwwewriwrreewqtqqt96664.5>X y y o2u2u y2u yo2 ", +"679qq909qqqtwqtrwrrwrtrqpqqq66666>4.>.. :. 2 ,2o oo yo yo ,o y ", +"6667q.q6qtqqteqeqeeitrweqqt999q696>a4.>6>: .y uo 2yoo2u,oo2 y .", +"4666666a49qqqtqqwewrtsrssirtwwqtqww994d6X>X. u 2yoof o , 2yf .", +"X6X6X>X486qqqqwrsghhjkllzjkkkhhxgsssrqtqq76d6.>>.. 2 22y 2 ", +". > >1X.44qwtrhxkchkcvzccbllzjkhnmMNmNsNrsqqq766>B . y .:2 y . ", +" . .>1X66qtVhmCkkjcllzvclclcllvkhmxsMMsMxsrtw96XZ..>. . :>. > ", +" .>X>77wgmxknkkkvvllvvcAAvlvvklvklkhmsssMMMStq766a>>>> : : ", +"2u >X67txmxnhknkllDkAllAlvAFFFFGFGAlknxmhHssMsMttq77d>Z ::> y ", +"o2u .:a7tNsshhCnkDmnsmcvklvGFGGAlDDvAvkkkkkmsstssxMttd6d>:B > ", +"22 :.>6tsssNssxmmmmZSkllklFJFGGKKLmkvllnknknnxSsstsrttdd6d>: y2", +"2y >adNttrtssmP>a::SmmnlvJIJIAPPZKkDlnPmkkkDmmxStqPwq70.>X yuo=", +"2fy >ZqtwwVttUP:a>:YLmmmlAGITGDPZYZmDnxZZLnnnknssttq7t07Z Y o==", +"u2 :>6wtqwwtUd>Y::uyZPxnnAGJGGAPKZPmnmSY:ZPmknnhsSttq>a.>: yuou+", +"2u .6qqRtPq>::uu:uEZmmmsxmnAGvSPSPmSSPuEuyZmxCmmssW06Z> y;o=o=", +"2u :.667q9qZZ:Y::uEuYLssPPPSnkvnSPSnmL:Q!y!u0StsMsw0qt> you=++$", +"=u :.>6~~~~~:::u!=^uZLLKKLPPPPSKKPLPP/(Q~~Z07dd00PtP.fyo===+$=$", +"ouy :.>Z~~q7~~:u=)=33uPLKKPPLZPPPPPKPQ/3(~~dddddd>yuyuo===+$_+$!", +"u=uu >:~~qqq~~:y~~~~3!Y~~~~PPP~~~~PP)~~Q~~ZZ~~~~dZ:o====$o!o$$$=", +"+!o=.>>~~7qq~~:~~=Q~~/~~PP~~P~~PK~~=~~(~~~:~~dd~>:2yo=$=o!=$$)$=", +"o=o= >~~>6qq~~~~y=)~~~~)ZZKP~~KPP~~~~/)u~~~~d0Y~>:uu+!+$$$$$@$$$", +"=+$=u>~~6q6~~d~~~~~~)~~Q3!uY~~Zu~~/~~!y~~`~~~~~~u=u=+$!$$$$$%$$$", +"$@++u>~~766~~~~>Y:>Y~~2!)~~~~!!''~~~!y''~'':''::uu=''@'''''$%%#%", +"@=$=o~~ddd~~Z~~X>~~:~~yu~~2~~uu'''~~f'''E''f'''uuo'''$''%%$(%(%%", +"@!++o~~~~~~>6d~~~~6Z.~~~~uuy~~~'''y~~'''u''~'''==u'''$''$%%%%&%$", +"+$$=+=,2 . :ZZ.Zd0d.Z> Z:y :YyY'''':''''=''o''''$''''%'''''%]##(", +"$$$$++oyu y :>>0>2d.:Z>>:>Y7::''o'y'=''u''$''$'$'%''&''&$&#&$%&", +"$3$$+@=ouuyuy Z>:>Z Zy>: ydy ''+'''!''=''$''$'''%''%''%(#(%&%*", +"3%%$$)++u2uouuyy :y y:yuuu:uu''$!'$!'')'')''%('(%''&''(%(%&(&%", +"$3%$$$=+=ouou=ouy2:uyuu2u=+=2uu''!!'_!''!''!''($'$(''&'''''(%&%(", +"%%]%$$$!++=+===+u=y2uoo=o+ou@!u=$!!$)$$($%(%($(%((%&&%&&&&%&%&%#", +"$$%#%$$@+$o=+=o===+oo===+++$=$=$)$$$3$%(!%](%(%(((&(&%%(%&%&%#&%"}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-colorful-xx.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-colorful-xx.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,134 @@ +/* XPM */ +static char * mime-fancy-up_xpm[] = { +"64 42 89 1", +" c #B8B878785050", +". c #B0B070705050", +"X c #B0B070704848", +"o c #C8C880806060", +"O c #C8C888885858", +"+ c #C8C888886060", +"@ c #D0D090906868", +"# c #D8D898987070", +"$ c #D0D090907070", +"% c #D0D098987070", +"& c #D8D8A0A08080", +"* c #D8D8A0A07878", +"= c #C0C088886060", +"- c #D0D088886060", +"; c #C0C088885858", +": c #B0B078785858", +"> c #B0B070705858", +", c #C0C078785858", +"< c #D0D098986868", +"1 c #B8B870705050", +"2 c #C0C080805050", +"3 c #C8C898987070", +"4 c #A8A870704848", +"5 c #B0B068684848", +"6 c #A8A868684848", +"7 c #A0A068684848", +"8 c #A8A860604848", +"9 c #A0A068684040", +"0 c #A0A068685050", +"q c #A0A060604848", +"w c #989860604848", +"e c #989858584040", +"r c #909050504040", +"t c #909060604040", +"y c #B8B878786060", +"u c #B8B880806060", +"i c #909058584040", +"p c #989860604040", +"a c #A0A070704848", +"s c #808058584040", +"d c #A8A870705050", +"f c #B8B880805858", +"g c #787848483838", +"h c #686848483838", +"j c #686840404040", +"k c #606040403838", +"l c #585838383838", +"z c #505038383838", +"x c #787848484040", +"c c #484830303838", +"v c #484838383838", +"b c #505038383030", +"n c #606048484040", +"m c #707050504040", +"M c #787850504040", +"N c #808048484040", +"B c #B0B078785050", +"V c #808050504040", +"C c #606040404040", +"Z c #A0A070705050", +"A c #404038383838", +"S c #808058584848", +"D c #505040403838", +"F c #484838383030", +"G c #404030303030", +"H c #686848484040", +"J c #383830303030", +"K c #808068685050", +"L c #888860604848", +"P c #888868685050", +"I c #303028282828", +"U c #888858584848", +"Y c #A8A878785858", +"T c #383828282828", +"R c #989868684848", +"E c #B8B880806868", +"W c #909060604848", +"Q c #C8C898987878", +"! c #C8C890907878", +"~ c Gray60", +"^ c #C0C088886868", +"/ c #D0D0A8A88888", +"( c #D0D0A0A08080", +") c #C8C890907070", +"_ c #C8C888887070", +"` c #B0B080805858", +"' c Gray60", +"] c #D0D098988080", +"[ c black s backgroundToolBarColor", +" [.[ [X[.[ [o[+[+[+[@[@[@[$[%[@[%[%[#[%[%[*[%[*[%[%[%[@[@[+[O[o[", +"[:[ [ [>[,[o[o[+[@[+[@[+[@[@[-[@[$[@[<[%[%[%[%[&[%[%[@[@[@[+[O[O", +"1[ [ [ [ [o[2[;[+[-[+[@[@[+[+[@[@[@[@[$[@[@[$[%[%[#[$[@[+[+[O[O[", +"[>[.[.[.[ [,[o[o[=[o[+[o[+[o[o[=[+[+[o[=[+[+[$[@[$[$[@[+[+[o[o[+", +"2[ [.[.[.[.[ [ [,[ [ [ [X[.[ [.[ [ [ [o[ [o[@[@[@[@[@[+[=[o[;[;[", +"[.[1[4[4[4[4[.[4[1[4[5[6[7[4[4[4[.[.[ [ [ [2[o[=[o[o[o[2[ [2[o[o", +" [4[6[4[6[9[4[9[6[8[9[9[9[9[4[4[.[4[X[.[ [ [.[ [ [,[o[.[>[>[.[2[", +"[6[4[9[6[9[4[9[q[9[9[9[8[w[9[8[6[X[X[.[X[ [ [ [.[.[.[ [X[>[X[>[ ", +".[4[9[9[q[8[9[q[q[q[q[q[w[q[6[6[4[4[>[X[.[ [.[:[.[:[.[>[.[ [>[.[", +"[X[6[q[9[q[q[e[q[q[w[w[w[t[q[q[q[4[4[.[.[ [ [ [ [.[ [ [.[ [ [ [ ", +"6[9[q[9[9[q[w[e[r[w[r[e[q[q[t[6[6[.[>[ [ [ [ [ [2[2[ [y[u[y[2[ [", +"[7[q[9[9[q[t[q[r[r[w[t[q[q[q[6[6[>[.[.[ [.[ [ [2[ [o[y[ [o[,[ [ ", +"6[6[q[q[q[q[t[q[q[e[t[w[q[t[9[q[9[>[4[>[>[ [y[ [o[2[o[2[,[o[ [ [", +"[6[6[6[a[9[q[t[q[e[r[s[s[i[t[w[t[w[9[4[6[>[.[ [ [y[o[ [ [,[2[f[.", +"X[X[X[X[8[q[q[w[s[h[j[l[z[k[k[h[g[s[r[t[q[6[6[>[.[ [ [ [2[y[2[ [", +"[ [ [1[.[4[w[r[x[c[k[v[c[b[l[j[h[m[N[N[N[s[q[7[6[B[.[y[.[2[y[ [ ", +" [.[.[1[6[q[V[m[k[j[l[z[c[c[c[l[k[m[s[M[M[s[t[9[X[.[>[ [ [>[ [ [", +"[ [ [>[>[7[g[x[n[k[v[l[v[c[A[l[v[l[k[k[m[s[M[M[t[7[6[>[>[ [ [:[ ", +"2[ [ [X[7[x[x[h[n[l[D[A[l[l[A[F[F[F[A[k[x[h[s[M[M[t[7[d[Z[:[>[y[", +"[2[ [:[7[N[s[h[n[D[n[m[v[l[G[G[A[D[v[v[k[k[m[s[s[x[t[d[d[:[ [ [ ", +"2[ [.[6[s[s[s[x[m[m[S[l[k[F[F[G[K[m[v[l[k[k[n[S[s[s[t[d[6[>[ [y[", +"[y[ [a[N[t[t[s[P[a[:[m[n[v[I[I[P[Z[k[l[P[k[k[m[x[t[P[q[0[>[ [u[=", +"2[y[>[q[w[V[t[P[a[:[L[m[l[G[T[D[Z[Z[D[x[Z[n[n[n[s[t[7[0[Z[Y[ [=[", +"[2[:[6[t[w[t[d[Y[:[y[P[n[A[J[G[P[Z[m[m[Y[Z[m[n[h[S[t[>[.[:[y[o[+", +"2[ [.[q[R[P[>[:[u[u[Z[m[s[m[A[v[P[P[S[P[E[y[m[C[m[s[0[Z[ [y[o[o[", +"[u[:[6[7[9[Z[:[:[u[u[L[s[P[S[k[n[P[n[L[Q[y[u[S[s[s[0[t[ [y[u[+[$", +"=[ [:[>[~[~[~[:[u[=[u[L[K[L[P[P[K[P[P[/[Q[~[0[d[0[P[P[f[o[=[+[=[", +"[u[ [.[Z[~[7[~[u[)[3[u[L[K[P[Z[P[P[K[Q[3[~[d[d[d[>[u[u[=[=[$[+[!", +"u[u[ [:[~[q[~[:[~[~[3[Y[~[~[P[~[~[P[)[~[~[Z[~[~[d[:[=[=[$[![$[$[", +"[![=[>[~[7[q[~[~[=[~[/[~[P[~[~[P[~[=[~[~[~[~[d[~[:[y[=[=[![$[)[=", +"o[o[ [~[>[q[~[~[y[)[~[~[Z[K[~[K[P[~[~[)[~[~[d[Y[>[u[+[+[$[$[@[$[", +"[+[=[>[~[q[~[d[~[~[~[~[Q[![Y[~[u[~[~[![~[`[~[~[~[=[=[$[$[$[$[$[$", +"$[+[u[~[7[6[~[~[Y[>[~[2[)[~[~[!['[~[!['[~['['[:[u[=['['['['[%[#[", +"[=[=[~[d[d[~[~[X[~[:[~[u[~[~[u['['[~['['['[f['[u[o['[$['[%[([([%", +"@[+[o[~[~[~[6[~[~[6[.[~[~[u[~[~['[y[~['[u['['['[=['['['[$[%[%[%[", +"[$[=[=[2[.[:[Z[Z[0[.[>[Z[y[:[y['['[:['['['[o['['['['[%['['[%[#[(", +"$[$[+[o[u[y[ [>[0[2[.[Z[>[>[7[:['['['['[u['['[$[$[%['['[&[&[&[%[", +"[3[$[@[o[u[u[ [Z[:[Z[Z[>[ [y[y['[+['[!['['[$['['['['[%['[([([&[*", +"3[%[$[+[u[u[u[y[ [ [y[y[y[u[:[u['[![$['[)['['[%['[%['['[([([&[&[", +"[3[$[$[+[o[o[=[u[2[u[u[2[=[=[u['[!['[!['['[!['[$[$['[&['['[([&[(", +"%[][$[$[+[=[=[=[u[y[u[o[o[o[@[u[$[![)[$[$[([([([([%[&[&[&[%[%[%[", +"[$[#[$[@[$[=[=[=[=[o[=[=[+[$[$[$[$[$[$[([%[([([([([([%[([&[&[#[%"}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-dn.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-dn.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,26 @@ +#define e_width 64 +#define e_height 42 +static char e_bits[] = { + 0x39,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x42,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x8f,0xda,0x7f,0xb8,0xff,0xff,0xff,0xff,0x0c,0x41,0x02,0x00,0xf4, + 0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0xed,0xbf,0xed,0x00,0x00,0x00,0x00, + 0x44,0x2f,0x64,0xb2,0x02,0x00,0x00,0x00,0xb0,0x66,0x4c,0x36,0x00,0x00,0x00, + 0x00,0x00,0xff,0x78,0xff,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0xff,0x00,0x00, + 0x00,0x00,0x92,0xfd,0xff,0xff,0x00,0x00,0x00,0x00,0x44,0xf7,0xff,0x7f,0x00, + 0x00,0x00,0x00,0x00,0xf2,0xff,0x7f,0x20,0x00,0x00,0x00,0x00,0xc0,0xfc,0xff, + 0x3e,0x00,0x00,0x00,0x00,0x00,0x77,0xbf,0x6b,0x00,0x00,0x00,0x00,0x00,0x50, + 0xf7,0xaf,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0x3f,0x00,0x00,0x00,0x0a,0x00, + 0x80,0xfe,0x2f,0x00,0x00,0x68,0x00,0x00,0x00,0xff,0x2f,0x00,0x00,0x68,0x00, + 0x00,0x00,0xfc,0x1f,0x00,0x0d,0x3c,0x00,0x00,0x00,0xfa,0x1f,0x80,0x0e,0x3c, + 0x02,0x00,0x00,0xfe,0x1f,0xc0,0x0f,0x3c,0x80,0x01,0x20,0xff,0x0f,0xf0,0x0f, + 0x20,0x80,0x07,0x80,0xff,0x0f,0xe0,0x1f,0x00,0xc0,0x0f,0xc0,0xff,0x5f,0xff, + 0x1f,0x00,0xc0,0x07,0xc0,0xff,0x5f,0xf3,0x3f,0x00,0xe0,0x07,0xfe,0xff,0xff, + 0xf1,0xff,0xc7,0xf3,0xf3,0xfc,0xff,0xef,0xf1,0xff,0x6c,0xfe,0x9f,0xff,0xff, + 0xff,0xf1,0xff,0x30,0xfe,0xcf,0xff,0xff,0xff,0xd8,0xff,0xbf,0xff,0xff,0xff, + 0xff,0xff,0xf8,0xff,0x7f,0x3e,0xc9,0x27,0xf8,0x7f,0x6c,0xff,0x7f,0x1c,0x89, + 0x23,0xff,0xff,0xcf,0xe3,0x7f,0x1c,0x89,0x23,0xff,0xff,0x0d,0x60,0x7f,0x08, + 0x09,0x21,0xf8,0xff,0xff,0xa6,0x6f,0x2a,0x49,0x25,0xff,0xff,0x7f,0xd7,0x6f, + 0x22,0x49,0x24,0xff,0xff,0xff,0xff,0x7f,0x36,0xc9,0x26,0xff,0xff,0xff,0xff, + 0x7f,0x36,0xc9,0x26,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-simple-dn.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-simple-dn.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,57 @@ +/* XPM */ +static char *noname[] = { +/* width height ncolors chars_per_pixel */ +"64 42 8 1", +/* colors */ +"` c Gray60", +"a c #666666666666", +"b c #9A9A9A9A9A9A", +"c c #B0B0B0B0B0B0", +"d c #2A2A2A2A2A2A", +"e c #878787878787", +"f c Gray60", +"g c #434343434343", +/* pixels */ +"eeeeeeeeeeebbbbbbbbbbbbbbcbbccbccccccccccccccccccccccbbbbbbbbbbb", +"beeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbccccbcccccccccbbbbbbbbbbbb", +"eeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbcbcccccccbbbbbbbbbbbb", +"eeeeeeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb", +"eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbb", +"eeeeeeeeeeeeeeeeeeeeeeeeeaeeeeeeeeeeeeeeeeeeebbbbbbbbbbeeeeeebeb", +"eeeeeeeaeaaeeeaeeaaaaeaaaaaaeeeaeeeeeeeeeeeeeeeeeeebbeeeeeeeeeee", +"eeaeeaeeeaeeaaaaaaeaeaeaaaeaaaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", +"eeeaaaaaaaaaaaaaaaaaaaaaaaaeeeeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", +"eeeeaaaaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", +"eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeebeeeeeeeeeeebeeee", +"eaaaaaeaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeebebbeebeebeebeee", +"eeeaaeaeaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeebeeebbeeebbeeeee", +"eeeeeeeeeaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeebbeebeeeeeeeee", +"eeeeeeeeaeaaaaaaaagggggggggggggaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeeee", +"eeeeeeeeeeaaaagagggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeeee", +"eeeeeeeeeeaaagagggggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeee", +"eeeeeeeeaaaaaagggggggggggggggggggggggggaaaaaaaaaaaeeeeeeeeeeeeee", +"eeeeeeeeaaaaaggggggggggggggggggggdgdggggaaggaaaaaaaaaaeeeeeeeeee", +"beeeeeeaaaaaggggggagaagggggdgddggggggggggggaaaaaaaaaaeeeeeeeeeee", +"eeeeeeeaaaaaaaaaaaaeaggggggdgddaaaaggggggggggaaaaaaaaaeeeeeeeeee", +"eeeeeeeaaaaaaaaaeeeeaaagggddddgaaeaggggaaggggaaaaaaaaaaeeeeeeebb", +"eeeeeeaaaaaaaaaeeeeeaaaaggddddgaeeeaggaeeagggggaaaaaaaeaeeeeebbb", +"eeeeeeaaaaaaaeeeeeeeeaagggddddgaaeaagaaeeeaaggggaaaaaeeeeeeeebeb", +"eeeeeeaaaaaaeeeeeeeeeaaaaaaggdgaaaaaaaaeeeeeaagaaaaaeeeeeeebbbbb", +"eeeeeeeaaaaeeeeeeeeeeaaaaaaaggggaaagaaebbebeeaaaaaaeaaeeeebebbbb", +"beeeeeeefffffeeeebbbeeaaaaaaaaaaaaaaaaccbffeeaeeeeaaaeeebbbbbbbb", +"beeeeeeeffaaffeebbbbbeaaaaaaaeaaaaaaabcbcffeeeeeeeeeeebbbbbbbbbb", +"ebeeeeeffaaaffeeffffbbeffffaaaffffaabffbffeeffffeeebbbbbbbbbbbbb", +"bbbbeeeffaaaffeffbbffcffaaffaffaaffbffcfffeffeefeeeebbbbbbbbbbbb", +"bbbbeeffeeaaffffebbffffbeeaaffaaaffffcbeffffeeefeeeebbbbbbbbbbbb", +"bbbbeeffeaeffeffffffbffbbbeeffeeffcffbeffeffffffebebbbbbbbbbcbbb", +"bbbbeeffaeeffffeeeeeffebbffffbb``fffbe``f``e``eeeeb``b`````bcccc", +"bbbbbffeeeffeffeeffeffeeffeffee```ffe```e``e```eeb```b``ccbccccc", +"bbbbbffffffeeeffffeeeffffeeefff```eff```e``f```bbe```b``bccccccb", +"bbbbbbeeeeeeeeeeeeeeeeeeeeeeeee````e````b``b````b````c`````ccccc", +"bbbbbbbeeeeeeeeeeeeeeeeeeeeeaee``b`e`b``e``b``b`b`c``c``cbcccbcc", +"bbbbbbbbeeeeeeeeeeeeeeeeeeeeeee``b```b``b``b``b```c``c``cccccccc", +"bccbbbbbeeebeeeeeeeeeeeeeeeeeee``bb`bb``b``b``cc`cc``c``cccccccc", +"bbcbbbbbbbebebbeeeeeeeeeebbbeee``bb`bb``b``b``cb`bc``c`````ccccc", +"ccccbbbbbbbbbbbbebeeebbbbbbebbebbbbbbbbcbccccbcccccccccccccccccc", +"bbcccbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbccbccccccccccccccccccccccc" +}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-simple-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-simple-up.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,57 @@ +/* XPM */ +static char *noname[] = { +/* width height ncolors chars_per_pixel */ +"64 42 8 1", +/* colors */ +"` c #000000000000", +"a c #B8B878785050", +"b c #D0D0A8A88888", +"c c #585838383838", +"d c #303028282828", +"e c #FFFFFFFFFFFF", +"f c #D0D090906868", +"g c #909050504040", +/* pixels */ +"aaaaaaaaaaaffffffffffffffffffffffbfffffffbbfffbffbfbfffffffffffa", +"faaaaaaaaaffffffffffffffffffffffffffffffffffffbbffffffffffffffaf", +"aaaaaaaaafffafaffffffffffaffffffffffffffffffffffffffffffffffffff", +"aaaaaaaaaaaaafffafffffafffffffafffffffafffffffffffffffffffffffff", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffafffffffffffffffffffafaf", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffffffaffaaaaaafaf", +"aaaaaaaaaggaaagaagaggagggggaaaagaaaaaaaaaaaaaaaaaaaffaaaaaaaaaaa", +"aagaagaaagaaggggggagagaaggaggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaagggggggaggggggggggggggggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaggggggggggggggggggggggggggagaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaggggggggggggggggggggggggggggaaaaaaaaaaaaaaaaafaaaaaaaaaaafaaaa", +"aaggggagggggggggggggggggggggaaaaaaaaaaaaaaaaaaaafaffaafaafaafaaa", +"aaaagagagggggggggggggggggggggggagaaaaaaaaaaaaaaafaaaffaaaffaaaaa", +"aaaaaaaaaggggggggggggggggggggggggggggaaaaaaaaaaaaaffaafaaaaaaaaa", +"aaaaaaaaaaggggggggcccccccccccccggggggggggaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaggggcgcccccccccccccccccggggggggggggaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaagggcgcccccccccccccccccccgggggggggggggaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaggggcccccccccccccccccccccccccggggggggggaaaaaaaaaaaaaaa", +"aaaaaaaaaggggccccccccccccccccccccdcdccccggccggggggggaaaaaaaaaaaa", +"faaaaaaaggggccccccgcggcccccdcddccccccccccccggggggggggaaaaaaaaaaa", +"aaaaaaaggggggggggggagccccccdcddggggccccccccccgggggggggaaaaaaaaaa", +"aaaaaaagggggggggaaaagggcccddddcggagccccggccccgggggggggaaaaaaaaff", +"aaaaaagggggggggaaaaaggggccddddcgaaagccgaagcccccgggggagaaaaaaafff", +"aaaaaagggggggaaaaaaaaggcccddddcggaggcggaaaggccccgggggaaaaaaaafaf", +"aaaaaaggggggaaaaaaaaaggggggccdcggggggggaaaaaggcgggggaaaaaaaaffff", +"aaaaaaaagggaaaaaaaaaagggggggccccgggcggaffafaaggggggaggaaaafaffff", +"faaaaaaaeeeeeaaaafffaaggggggggggggggggbbfeeaaaaaaagggaaaffffffff", +"faaaaaaaeegaeeaafffffagggggggagggggggfbfbeeaaaaaaaaaaaffffffffff", +"afaaaaaeegggeeaaeeeeffaeeeegggeeeeggfeefeeaaeeeeaaafffffffffffff", +"ffffaaaeeaggeeaeeffeebeeggeegeeggeefeebeeeaeeaaeaaaaffffffffffff", +"ffffaaeeaaggeeeeaffeeeefaaggeegggeeeebfaeeeeaaaeaaaaffffffffffff", +"ffffaaeeagaeeaeeeeeefeefffaaeeaaeebeefaeeaeeeeeeafafffffffffffff", +"ffffaaeeaaaeeeeaaaaaeeaffeeeeff``eeefa``e``a``aaaaf``f`````fffff", +"fffffeeaaaeeaeeaaeeaeeaaeeaeeaa```eea```a``a```aaf```f``fffbfbff", +"fffffeeeeeeaaaeeeeaaaeeeeaaaeee```aee```a``e```ffa```f``fffffbff", +"ffffffaaaaaaaaaaaaaaaaaaaaaaaaa````a````f``f````f````f`````fbffb", +"fffffffaaaaaaaaaaaaaaaaaaaaaaaa``f`a`f``a``f``f`f`f``b``bfbfbffb", +"ffffffffaaaaaaaaaaaaaaaaaaaaaaa``f```f``f``f``f```f``f``fbfbfbfb", +"ffffffffaaafaaaaaaaaaaaaaaaaaaa``ff`ff``f``f``fb`bf``b``bfbfbbbf", +"ffffffffffafaffaaaaaaaaaafffaaa``ff`ff``f``f``bf`fb``b`````bfbfb", +"ffbfffffffffffffafaaaffffffaffaffffffffbffbfbfbfbbfbbfbbbbfbfbff", +"fffffffffffffffffffffffffffffffffffffffbffbbfbfbbbbbbffbfbfbffbf" +}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-simple-xx.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-simple-xx.xpm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,57 @@ +/* XPM */ +static char *noname[] = { +/* width height ncolors chars_per_pixel */ +"64 42 8 1", +/* colors */ +"` c #000000000000", +"a c #D0D0A8A88888", +"b c #B8B870705050", +"c c #888868685050", +"d c #999999999999", +"e c #505040403838", +"f c #303028282828", +"g c #787848483838", +/* pixels */ +"b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`", +"`b`b`b`b`b`b`b`b`a`b`a`b`a`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b", +"b`b`b`b`b`b`b`b`b`b`b`a`a`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`b`", +"`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b", +"b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b`", +"`b`b`b`b`b`b`b`b`b`b`b`b`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", +"b`b`b`b`b`c`b`c`b`b`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", +"`b`b`c`b`c`b`c`c`c`c`c`b`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", +"b`b`c`c`c`b`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", +"`b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", +"b`c`c`c`c`c`c`c`g`c`g`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", +"`c`c`c`c`c`c`c`g`g`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", +"b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", +"`b`b`b`b`c`c`c`c`c`g`g`g`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b", +"b`b`b`b`b`c`c`c`g`g`g`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b`b`b`", +"`b`b`b`b`b`c`g`g`e`e`e`e`e`e`g`g`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b", +"b`b`b`b`b`c`g`g`e`g`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`", +"`b`b`b`b`c`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b", +"b`b`b`b`c`g`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`", +"`b`b`b`c`g`g`g`e`e`e`g`e`e`f`f`e`e`e`e`e`e`g`g`g`g`c`b`b`b`b`b`b", +"b`b`b`b`g`g`g`g`g`g`c`e`e`e`e`f`c`g`e`e`e`e`e`c`g`g`c`b`b`b`b`b`", +"`b`b`b`g`c`c`g`c`b`b`g`e`e`f`f`c`b`e`e`c`e`e`g`g`c`c`c`c`b`b`b`b", +"b`b`b`c`c`g`c`c`b`b`c`g`e`f`f`e`b`b`e`g`b`e`e`e`g`c`c`c`b`b`b`b`", +"`b`b`b`c`c`c`b`b`b`b`c`e`e`f`f`c`b`g`g`b`b`g`e`g`c`c`b`b`b`b`b`b", +"b`b`b`c`c`c`b`b`b`b`b`g`g`g`e`e`c`c`c`c`b`b`g`e`g`g`c`b`b`b`b`b`", +"`b`b`b`c`c`b`b`b`b`b`c`g`c`c`e`e`c`e`c`a`b`b`c`g`g`c`c`b`b`b`b`a", +"b`b`b`b`d`d`d`b`b`b`b`c`c`c`c`c`c`c`c`a`a`d`c`b`c`c`c`b`b`b`b`b`", +"`b`b`b`b`d`c`d`b`a`a`b`c`c`c`b`c`c`c`a`a`d`b`b`b`b`b`b`b`b`a`b`a", +"b`b`b`b`d`c`d`b`d`d`a`b`d`d`c`d`d`c`a`d`d`b`d`d`b`b`b`b`a`a`a`a`", +"`a`b`b`d`c`c`d`d`b`d`a`d`c`d`d`c`d`b`d`d`d`d`b`d`b`b`b`b`a`a`a`b", +"b`b`b`d`b`c`d`d`b`a`d`d`b`c`d`c`c`d`d`a`d`d`b`b`b`b`b`b`a`a`a`a`", +"`b`b`b`d`c`d`b`d`d`d`d`a`a`b`d`b`d`d`a`d`b`d`d`d`b`b`a`a`a`a`a`a", +"a`b`b`d`c`b`d`d`b`b`d`b`a`d`d`a`d`d`a`d`d`d`d`b`b`b`d`d`d`d`a`a`", +"`b`b`d`b`b`d`d`b`d`b`d`b`d`d`b`d`d`d`d`d`d`b`d`b`b`d`a`d`a`a`a`a", +"a`b`b`d`d`d`b`d`d`b`b`d`d`b`d`d`d`b`d`d`b`d`d`d`b`d`d`d`a`a`a`a`", +"`a`b`b`b`b`b`b`b`c`b`b`b`b`b`b`d`d`b`d`d`d`b`d`d`d`d`a`d`d`a`a`a", +"a`a`b`b`b`b`b`b`c`b`b`b`b`b`c`b`d`d`d`d`b`d`d`a`a`a`d`d`a`a`a`a`", +"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`b`d`a`d`d`a`d`d`d`d`a`d`a`a`a`a", +"a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`b`d`a`a`d`a`d`d`a`d`a`d`d`a`a`a`a`", +"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`a`d`a`d`d`a`d`a`a`d`a`d`d`a`a`a", +"a`a`a`a`b`b`b`b`b`b`b`b`b`b`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`", +"`a`a`a`a`a`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a" +}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-up.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,32 @@ +#define e_width 64 +#define e_height 42 +static unsigned char e_bits[] = { + 0xc6, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0xbd, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x25, 0x80, 0x47, + 0x00, 0x00, 0x00, 0x00, 0xf3, 0xbe, 0xfd, 0xff, 0x0b, 0x00, 0x00, 0x00, + 0xfe, 0xff, 0xff, 0xff, 0xff, 0x12, 0x40, 0x12, 0xff, 0xff, 0xff, 0xff, + 0xbb, 0xd0, 0x9b, 0x4d, 0xfd, 0xff, 0xff, 0xff, 0x4f, 0x99, 0xb3, 0xc9, + 0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x87, 0x00, 0xff, 0xff, 0xff, 0xff, + 0x2f, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0x6d, 0x02, 0x00, 0x00, + 0xff, 0xff, 0xff, 0xff, 0xbb, 0x08, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff, + 0xff, 0x0d, 0x00, 0x80, 0xdf, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x03, 0x00, + 0xc1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x88, 0x40, 0x94, 0xff, 0xff, 0xff, + 0xff, 0xff, 0xaf, 0x08, 0x50, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, 0x00, + 0xc0, 0xff, 0xff, 0xff, 0xf5, 0xff, 0x7f, 0x01, 0xd0, 0xff, 0xff, 0x97, + 0xff, 0xff, 0xff, 0x00, 0xd0, 0xff, 0xff, 0x97, 0xff, 0xff, 0xff, 0x03, + 0xe0, 0xff, 0xf2, 0xc3, 0xff, 0xff, 0xff, 0x05, 0xe0, 0x7f, 0xf1, 0xc3, + 0xfd, 0xff, 0xff, 0x01, 0xe0, 0x3f, 0xf0, 0xc3, 0x7f, 0xfe, 0xdf, 0x00, + 0xf0, 0x0f, 0xf0, 0xdf, 0x7f, 0xf8, 0x7f, 0x00, 0xf0, 0x1f, 0xe0, 0xff, + 0x3f, 0xf0, 0x3f, 0x00, 0xa0, 0x00, 0xe0, 0xff, 0x3f, 0xf8, 0x3f, 0x00, + 0xa0, 0x0c, 0xc0, 0xff, 0x1f, 0xf8, 0x01, 0x00, 0x00, 0x0e, 0x00, 0x38, + 0x0c, 0x0c, 0x03, 0x00, 0x10, 0x0e, 0x00, 0x93, 0x01, 0x60, 0x00, 0x00, + 0x00, 0x0e, 0x00, 0xcf, 0x01, 0x30, 0x00, 0x00, 0x00, 0x27, 0x00, 0x40, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x07, 0x00, 0x80, 0xc1, 0x36, 0xd8, 0x07, + 0x80, 0x93, 0x00, 0x80, 0xe3, 0x76, 0xdc, 0x00, 0x00, 0x30, 0x1c, 0x80, + 0xe3, 0x76, 0xdc, 0x00, 0x00, 0xf2, 0x9f, 0x80, 0xf7, 0xf6, 0xde, 0x07, + 0x00, 0x00, 0x59, 0x90, 0xd5, 0xb6, 0xda, 0x00, 0x00, 0x80, 0x28, 0x90, + 0xdd, 0xb6, 0xdb, 0x00, 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x00, + 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x07, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + }; diff -r 498bf5da1c90 -r 0d2f883870bc etc/vm/mime-xx.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/vm/mime-xx.xbm Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,26 @@ +#define ee_width 64 +#define ee_height 42 +static char ee_bits[] = { + 0xc6,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x70,0x25,0x80,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0x12,0x40,0x12,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0xfd,0xff,0xff,0xff,0x4f,0x99,0xb3,0xc9,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0x2f,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xbb,0x08,0x00,0x80,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xdf,0xff,0xff,0xff,0xff,0x3f,0x03,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x94,0xff,0xff,0xff,0xff,0xff,0xaf, + 0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xf5,0xff, + 0x7f,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0x97,0xff, + 0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x7f,0xf1,0xc3, + 0xfd,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x0f,0xf0, + 0xdf,0x7f,0xf8,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x00, + 0xe0,0xff,0x3f,0xf8,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x0e,0x00,0x38,0x0c,0x0c,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x0e,0x00,0xcf,0x01,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x07,0x00,0x80,0xc1,0x36,0xd8,0x07,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x30,0x1c,0x80,0xe3,0x76,0xdc,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0x59,0x90,0xd5,0xb6,0xda,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xc9,0x36,0xd9,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0x00,0x00,0x00,0x00,0x00}; diff -r 498bf5da1c90 -r 0d2f883870bc etc/w3/stylesheet --- a/etc/w3/stylesheet Mon Aug 13 09:12:43 2007 +0200 +++ b/etc/w3/stylesheet Mon Aug 13 09:13:56 2007 +0200 @@ -47,7 +47,6 @@ ** Since Emacs-19 doesn't handle mixed-sized fonts very well just yet, ** we only use them under XEmacs. Hopefully, this will change soon. */ - @media xemacs { h1 { font-size : +12pt } h2 { font-size : +6pt } @@ -72,7 +71,6 @@ @media emacs { h1,h2,h3, h4,h5,h6 { - font-style: small-caps; text-decoration: underline; color: blue; } @@ -88,6 +86,25 @@ blockquote{ display: block; margin-left: 5; margin-right: 5; } /* +** How to draw form elements. +** This is an extension in Emacs-W3 (and perhaps soon E-Scape) +** Since there are so many different types of input fields, you should be +** able to control formatting based on that. Enter pseudo-classes. +** +** This functionality will be removed as soon as the W3C comes up with +** the standard way to do this, perhaps in CSS level 2. +*/ +input:text, +input:integer, +input:float, +input:url, +input:text { text-decoration: underline; } +input:submit { color: green; text-decoration: none; } +input:reset { color: red; text-decoration: none; } +input:button { color: yellow; text-decoration: none; } +input:image { text-decoration: none; } + +/* ** List formatting instructions */ @@ -136,7 +153,6 @@ ** Hypertext link coloring */ -a { cursor: hand2 } a:link { color: #FF0000 } a:visited { color: #B22222 } a:active { color: #FF0000 } diff -r 498bf5da1c90 -r 0d2f883870bc info/dir --- a/info/dir Mon Aug 13 09:12:43 2007 +0200 +++ b/info/dir Mon Aug 13 09:13:56 2007 +0200 @@ -46,10 +46,9 @@ Packages: -* 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. -* Dired:: Manual for Tree Dired. +* Custom:: Customization Library for Emacs * Ediff:: A Visual Interface to Unix Diff and Patch Utilities. * External-Widget:: Use XEmacs as a text widget inside of another program. @@ -77,6 +76,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 498bf5da1c90 -r 0d2f883870bc lib-src/ChangeLog --- a/lib-src/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,7 @@ +Thu Feb 13 11:32:47 1997 Steven L Baur + + * Makefile.in.in: Install pstogif script. + Sun Dec 29 17:16:45 1996 Martin Buchholz * update-elc.sh (make_special_commands): Make ilisp be a little diff -r 498bf5da1c90 -r 0d2f883870bc lib-src/Makefile.in.in --- a/lib-src/Makefile.in.in Mon Aug 13 09:12:43 2007 +0200 +++ b/lib-src/Makefile.in.in Mon Aug 13 09:13:56 2007 +0200 @@ -102,7 +102,7 @@ /* Things that a user might actually run, which should be installed in bindir. */ INSTALLABLES = etags ctags emacsclient b2m gnuclient gnuattach gnudoit -INSTALLABLE_SCRIPTS = rcs-checkin +INSTALLABLE_SCRIPTS = rcs-checkin pstogif /* Things that Emacs runs internally, or during the build process, which should not be installed in bindir. */ diff -r 498bf5da1c90 -r 0d2f883870bc lib-src/tm-au --- a/lib-src/tm-au Mon Aug 13 09:12:43 2007 +0200 +++ b/lib-src/tm-au Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-au,v 1.5 1997/01/30 02:22:29 steve Exp $ +# $Id: tm-au,v 1.6 1997/02/15 22:20:26 steve Exp $ # # Copyright 1994,1995,1996,1997 Free Software Foundation, Inc. @@ -38,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 498bf5da1c90 -r 0d2f883870bc lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 09:12:43 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 09:13:56 2007 +0200 @@ -85,6 +85,7 @@ } make_special vm +make_special efs #make_special ediff elc #make_special viper elc make_special gnus some diff -r 498bf5da1c90 -r 0d2f883870bc lib-src/update-elc.sh-STEVE --- a/lib-src/update-elc.sh-STEVE Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,130 +0,0 @@ -#!/bin/sh -# update-elc.sh --- recompile all missing or out-or-date .elc files - -# Author: Jamie Zawinski, Ben Wing, Martin Buchholz -# Maintainer: Martin Buchholz -# Keywords: recompile .el .elc - -### Commentary: -## Recompile all .elc files that need recompilation. Requires a -## working version of 'xemacs'. Correctly handles the case where the -## .elc files are missing; thus you can execute 'rm lisp/*/*.elc' -## before running this script. Run this from the parent of the -## `lisp' directory, or another nearby directory. - -set -eu - -# Try to find the lisp directory in several places. -# (Sun workspaces have an `editor' directory) -for dir in . .. ../.. editor ../editor ; do - if test -d $dir ; then cd $dir ; break ; fi -done - -if test ! -d lisp/. ; then - echo "$0: Can't find the \`lisp' directory." - exit 1 -fi - - -EMACS=${XEMACS:-./src/xemacs}; export EMACS -REAL=`cd \`dirname $EMACS\` ; pwd | sed 's:^/tmp_mnt::'`/`basename $EMACS` -echo "Recompiling in `pwd|sed 's:^/tmp_mnt::'`" -echo " with $REAL..." - - -# $els is a list of all .el files -# $elcs is a list of all .elc files -els=/tmp/rcl1.$$ ; elcs=/tmp/rcl2.$$ -rm -f $els $elcs -trap "rm -f $els $elcs" 0 1 2 3 15 -find lisp/. -name SCCS -prune -o -name '*.el' -print | sort > $els -find lisp/. -name SCCS -prune -o -name '*.elc' -print | sed 's/elc$/el/' | sort > $elcs - - -echo "Deleting .elc files without .el files..." -comm -13 $els $elcs | sed -e '\!/vm.el!d' -e '\!/w3.el!d' -e 's/el$/elc/' | \ - while read file ; do echo rm "$file" ; rm "$file" ; done -echo "Deleting .elc files without .el files... Done" - - -# Compute patterns to ignore when searching for files -ignore_dirs="egg its quail" # ### Not ported yet... - -# Only use Mule XEmacs to compile Mule-specific elisp dirs -echo "Checking for Mule support..." -# You cannot just use 'test -n' here because it will fail on a null -# return value (null != null string) -mule_check=`$REAL -batch -no-site-file \ - -eval \(when\ \(featurep\ \'mule\)\ \(message\ \"yes\"\)\) 2>&1` -if [ -z "$mule_check" ]; then - ignore_dirs="$ignore_dirs mule" -fi - -# first recompile the byte-compiler, so that the other compiles take place -# with the latest version (assuming we're compiling the lisp dir of the emacs -# we're running, which might not be the case, but often is.) -echo "Checking the byte compiler... " -$REAL -batch -q -no-site-file -f batch-byte-recompile-directory lisp/bytecomp - -# Prepare for byte-compiling directories with directory-specific instructions -make_special_commands='' -make_special () { - dir="$1"; shift; - ignore_dirs="$ignore_dirs $dir" - make_special_commands="$make_special_commands \ -echo \"Compiling in lisp/$dir\"; \ -(cd \"lisp/$dir\"; \ -${MAKE:-make} EMACS=$REAL ${1+$*}); \ -echo \"lisp/$dir done.\";" -} - -make_special vm -make_special ediff elc -make_special viper elc -make_special gnus some -make_special w3 -make_special url # really part of w3 -make_special hyperbole elc -make_special oobr HYPB_ELC= elc -make_special eos -k # not stricly necessary... -make_special ilisp compile -f Makefile - -ignore_pattern='' -for dir in $ignore_dirs ; do - ignore_pattern="${ignore_pattern}/\\/$dir\\//d -/\\/$dir\$/d -" -done - -# Other special-case filenames that don't get byte-compiled -ignore_pattern="$ignore_pattern"' -\!/,!d -\!/edebug/edebug-test.el$!d -\!/emulators/edt.el$!d -\!/energize/energize-load.el$!d -\!/energize/write-file.el$!d -\!/paths.el$!d -\!/prim/loadup.el$!d -\!/prim/loadup-el.el$!d -\!/prim/update-elc.el$!d -\!/site-start.el$!d -\!/site-load.el$!d -\!/site-init.el$!d -\!/version.el$!d -\!/sunpro/sunpro-load.el$!d -' - -echo "Compiling files without .elc..." -NUMTOCOMPILE=20 # compile this many files with each invocation -comm -23 $els $elcs | sed "$ignore_pattern" | \ - xargs -t -n$NUMTOCOMPILE $REAL -batch -q -no-site-file -f batch-byte-compile -echo "Compiling files without .elc... Done" - - -echo "Compiling files with out-of-date .elc..." -find lisp/. -name SCCS -prune -o -type d -print | sed "$ignore_pattern" | \ - xargs -t $REAL -batch -q -no-site-file -f batch-byte-recompile-directory -echo "Compiling files with out-of-date .elc... Done" - - -eval "$make_special_commands" diff -r 498bf5da1c90 -r 0d2f883870bc lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,145 @@ +Sat Feb 15 13:58:14 1997 Kyle Jones + + * packages/info.el: Don't call switch-to-buffer if the Info frame + is being deleted. + +Sat Feb 15 12:07:46 1997 Steven L Baur + + * prim/simple.el (previous-line): Allow escape from signaled error + on buffer boundary. + (next-line): Ditto. + +Sat Feb 15 11:05:29 1997 Kyle Jones + * utils/redo.el: made before and after status messages so that + the user is aware if a long action is still being processed. + + rolled version number up to 1.00, since the package seems to be + stable. + + cosmetic changes so the file could be included in the XEmacs + distribution. + +Sat Feb 15 11:13:05 1997 Hrvoje Niksic + + * prim/simple.el (line-move-ignore-invisible): Change default to + t. + +Sat Feb 15 01:04:21 1997 Hrvoje Niksic + + * prim/macros.el: Removed. Superseded by new version in + edmacro.el. + +Fri Feb 14 23:29:16 1997 Adrian Aichner + + * modes/executable.el (executable-set-magic): Correct for the #! + getting lost. + +Fri Feb 14 23:10:58 1997 Steven L Baur + + * prim/modeline.el (modeline-modified-map): Call + vc-toggle-read-only instead of toggle-read-only to be consistent + with override of `C-x C-q'. + +Fri Feb 14 16:11:10 1997 Jonathon Edwards + + * packages/blink-cursor.el (blink-cursor-post-command-hook): stop + cursor blink momentarily after receiving user input. + +Fri Feb 14 15:26:38 1997 Jacques Duthen + + * x11/x-menubar.el (default-menubar): mine goes into games menu. + +Thu Feb 13 22:16:09 1997 Michael Sperber + + * prim/files.el (recover-session-finish): Modify for efs. + +Thu Feb 13 21:23:07 1997 Steven L Baur + + * prim/files.el (file-remote-p): New function. + + * sunpro/sunpro-load.el: Do not dump mime-setup under any + circumstances. + +Thu Feb 13 17:58:09 1997 Richard Mlynarik + + * prim/obsolete.el (insert-before-markers-and-inherit): Correct + typo. + +Wed Feb 12 17:48:59 1997 Steven L Baur + + * comint/gdb.el (gdb-control-c-subjob): Nuke this loser. + +Wed Feb 12 13:58:01 1997 Hrvoje Niksic + + * utils/edmacro.el: New file. + +Wed Feb 12 09:00:48 1997 Steven L Baur + + * prim/sound.el (load-sound-file): Update documentation of + restrictions on what machines XEmacs can play sound on. + +Tue Feb 11 09:39:25 1997 Steven L Baur + + * prim/glyphs.el (init-glyphs): Correct autodetection to find + GIF89. Look for PNG. + +Mon Feb 10 21:37:54 1997 Steven L Baur + + * prim/frame.el (show-temp-buffer-in-current-frame): Conditional + shrink-to-fit behavior on `temp-buffer-shrink-to-fit'. + + * packages/apropos.el (apropos-print): Ditto. + + * prim/lisp.el (lisp-complete-symbol): Ditto. + + * prim/help.el (with-displaying-help-buffer): Ditto. + +Mon Feb 10 20:58:19 1997 Hrvoje Niksic + + * x11/x-toolbar.el: Allow customization of toolbar functions by + customizable variables. + +Mon Feb 10 14:58:05 1997 Greg Klanderman + + * comint/gdb.el (gdb-mode): Correct setting of obsolete hook. + +Sun Feb 9 19:55:03 1997 Steven L Baur + + * prim/obsolete.el (define-compatible-variable-alias): New function. + (define-compatible-variable-alias): New function. + .*mode-line.*, frame-parameters, modify-frame-parameters, + x-display-.* all made compatible not obsolete. + + * bytecomp/bytecomp.el (byte-compile-variable-ref): Warn for + compatibility symbols. + (byte-compile-compatible): New function. + + * bytecomp/bytecomp-runtime.el (make-compatible): New function. + (make-compatible-variable): New function. + +Sun Feb 9 19:14:25 1997 Kyle Jones + + * utils/redo.el: New file. + + * utils/floating-toolbar.el: New file. + +Sun Feb 9 15:19:46 1997 Steven L Baur + + * custom/custom.el: Remove ;;;###autoloads since this file is + dumped with XEmacs. + +Sun Feb 9 00:28:20 1997 Per Abrahamsen + + * custom/widget.el: New file. + + * custom/widget-example.el: New file. + + * custom/widget-edit.el: New file. + + * custom/custom.el: New file. + + * custom/custom-edit.el: New file. + Fri Feb 7 03:09:32 1997 Alastair Burt * bytecomp/bytecomp.el (byte-compile-insert-header): Correct diff -r 498bf5da1c90 -r 0d2f883870bc lisp/bytecomp/bytecomp-runtime.el --- a/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 09:13:56 2007 +0200 @@ -113,6 +113,34 @@ (put var 'byte-obsolete-variable new) var) +;; By overwhelming demand, we separate out truly obsolete symbols from +;; those that are present for GNU Emacs compatibility. +(defun make-compatible (fn new) + "Make the byte-compiler know that FUNCTION is provided for compatibility. +The warning will say that NEW should be used instead. +If NEW is a string, that is the `use instead' message." + (interactive "aMake function compatible: \nxCompatible replacement: ") + (let ((handler (get fn 'byte-compile))) + (if (eq 'byte-compile-compatible handler) + (setcar (get fn 'byte-compatible-info) new) + (put fn 'byte-compatible-info (cons new handler)) + (put fn 'byte-compile 'byte-compile-compatible))) + fn) + +(defun make-compatible-variable (var new) + "Make the byte-compiler know that VARIABLE is provided for compatibility. +and NEW should be used instead. If NEW is a string, then that is the +`use instead' message." + (interactive + (list + (let ((str (completing-read "Make variable compatible: " + obarray 'boundp t))) + (if (equal str "") (error "")) + (intern str)) + (car (read-from-string (read-string "Compatible replacement: "))))) + (put var 'byte-compatible-variable new) + var) + (put 'dont-compile 'lisp-indent-hook 0) (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). diff -r 498bf5da1c90 -r 0d2f883870bc lisp/bytecomp/bytecomp.el --- a/lisp/bytecomp/bytecomp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/bytecomp/bytecomp.el Mon Aug 13 09:13:56 2007 +0200 @@ -104,6 +104,8 @@ ;;; a macro to a lambda or vice versa, ;;; or redefined to take other args) ;;; 'obsolete (obsolete variables and functions) +;;; 'pedantic (references to Emacs-compatible +;;; symbols) ;;; byte-compile-emacs19-compatibility Whether the compiler should ;;; generate .elc files which can be loaded into ;;; generic emacs 19. @@ -350,6 +352,7 @@ redefine function cell redefined from a macro to a lambda or vice versa, or redefined to take a different number of arguments. obsolete use of an obsolete function or variable. + pedantic warn of use of compatible symbols. The default set is specified by `byte-compile-default-warnings' and normally encompasses all possible warnings. @@ -949,6 +952,16 @@ (car new) (format "use %s instead." (car new))))) (funcall (or (cdr new) 'byte-compile-normal-call) form))) + +;;; Used by make-obsolete. +(defun byte-compile-compatible (form) + (let ((new (get (car form) 'byte-compatible-info))) + (if (memq 'pedantic byte-compile-warnings) + (byte-compile-warn "%s is provided for compatibility; %s" (car form) + (if (stringp (car new)) + (car new) + (format "use %s instead." (car new))))) + (funcall (or (cdr new) 'byte-compile-normal-call) form))) ;; Compiler options @@ -2603,6 +2616,13 @@ (if (stringp ob) ob (format "use %s instead." ob))))) + (if (and (get var 'byte-compatible-variable) + (memq 'pedantic byte-compile-warnings)) + (let ((ob (get var 'byte-compatible-variable))) + (byte-compile-warn "%s is provided for compatibility; %s" var + (if (stringp ob) + ob + (format "use %s instead." ob))))) (if (memq 'free-vars byte-compile-warnings) (if (eq base-op 'byte-varbind) (setq byte-compile-bound-variables diff -r 498bf5da1c90 -r 0d2f883870bc lisp/comint/gdb.el --- a/lisp/comint/gdb.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/comint/gdb.el Mon Aug 13 09:13:56 2007 +0200 @@ -267,7 +267,7 @@ ;; XEmacs change: (make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'gdb-delete-arrow-extent nil t) - (setq comint-input-sentinel 'shell-directory-tracker) + (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) (run-hooks 'gdb-mode-hook)) (defun gdb-delete-arrow-extent () @@ -652,11 +652,13 @@ (goto-char (point-max)) (insert comm))) -(defun gdb-control-c-subjob () - "Send a Control-C to the subprocess." - (interactive) - (process-send-string (get-buffer-process (current-buffer)) - "\C-c")) +(fset 'gdb-control-c-subjob 'comint-interrupt-subjob) + +;(defun gdb-control-c-subjob () +; "Send a Control-C to the subprocess." +; (interactive) +; (process-send-string (get-buffer-process (current-buffer)) +; "\C-c")) (defun gdb-toolbar-break () (interactive) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/custom/ChangeLog --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,1228 @@ +Sat Feb 15 22:27:07 1997 Per Abrahamsen + + * Version 1.40 released. + +Sat Feb 15 22:18:57 1997 Per Abrahamsen + + * custom-edit.el: Use the `changed' state. + +Fri Feb 14 12:46:46 1997 Per Abrahamsen + + * Version 1.39 released. + +Fri Feb 14 12:35:15 1997 Per Abrahamsen + + * custom-edit.el (custom-variable-action): Capitalize. + (custom-face-action): Ditto. + (custom-group-action): Ditto. + * widget-edit.el (widget-choose): Use title in XEmacs. + Patch by Jens Lautenbacher . + +Thu Feb 13 21:14:41 1997 Per Abrahamsen + + * Version 1.38 released. + +Thu Feb 13 15:15:24 1997 Per Abrahamsen + + * custom-edit.el (custom-buffer-create): Added `Done' button. + + * custom-edit.el (custom-variable-state-set): Customized to + factory setting is the same as uncustomized. + (custom-variable-set): Did not set `customized-value' right. + + * widget-edit.el (widget-plist-member): Changed to defsubst. + (widget-get): Made it non-recursive. + + * widget-edit.el (widget-glyph-insert-glyph): New function. + (widget-glyph-insert): Use it. + (widget-push-button-gui): New option. + (widget-push-button-cache): New variable. + (widget-gui-action): New function. + (widget-push-button-value-create): New function. + (push-button): Use it. + (widget-editable-list-gui): New option. + (widget-editable-list-format-handler): Use it. + (widget-editable-list-value-create): Ditto. + This implements GUI push buttons. + + * Version 1.37 released. + +Thu Feb 13 13:51:20 1997 Per Abrahamsen + + * custom-edit.el (custom-redraw): Protect point. + + * widget-edit.el (widget-button1-click): New function. + (widget-keymap): Bind it. + + * Version 1.36 released. + +Thu Feb 13 13:16:34 1997 Per Abrahamsen + + * custom.el: Removed all `;;;###autoload' at the request of Steven + L Baur . + Don't call `autoload' or `custom-menu-reset' when `load-gc' is + fbound. + + * Version 1.35 released. + +Thu Feb 13 10:37:18 1997 Per Abrahamsen + + * widget-edit.el (boolean): Forgot terminating newline in :format. + +Wed Feb 12 18:49:03 1997 Per Abrahamsen + + * Version 1.34 released. + +Wed Feb 12 09:13:52 1997 Per Abrahamsen + + * widget-edit.el (widget-field-keymap): Disabled menu-bar in the + worng keymap. + (widget-text-keymap): Ditto. + (widget-glyph-directory): Default to "data-directory/custom/'. + + * Version 1.33 released. + +Wed Feb 12 09:11:23 1997 Per Abrahamsen + + * Makefile (TEXT): Added `check0.xpm' and `check1.xpm'. + + * widget-edit.el (checkbox): Add glyphs. + +Mon Feb 10 22:52:03 1997 Per Abrahamsen + + * widget-browse.el (widget-browse-sexps): New function. + (:args): Use it. + (widget-browse-action): New function. + (widget-browse): Use it. + (widget-browse-widgets): Use it. + + * Version 1.32 released. + +Mon Feb 10 15:39:45 1997 Per Abrahamsen + + * widget-browse.el (widget-browse-sexp): Catch printing errors. + (widget-browse-widgets): Print types instead of numbers. + + * all: Renamed `widget-name' to `widget-type'. + + * widget-edit.el (widget-button-click): Call the right command. + + * widget.texi (Basic Types): Documented new glyph options. + + * Version 1.31 released. + +Mon Feb 10 13:04:14 1997 Per Abrahamsen + + * widget-edit.el (widget-glyph-directory): New option. + (widget-glyph-enable): New option. + (widget-glyph-insert): New function. + (widget-toggle-value-create): Use it. + (radio-button): Use it. + (widget-field-activate): Only look for a field + (widget-button-click): Handle glyph events. + (widget-default-create): Handle `:glyph'. + * widget.el (:on-glyph): New keyword. + (:off-glyph): Ditto. + (:glyph): Ditto. + * widget.texi (toggle): Documented them.. + (Basic Types): Ditto. + * radio1.xpm: New file. + * radio0.xpm: Ditto. + Original patch provided by Robert Bihlmeyer . + + * widget-browse.el (widget-browse): Add group. + (widget-browse-mode-menu): Add commands. + + * widget-edit.el (widget-keymap): Bind [mouse-2-down] instead of + [mouse-2]. + + * widget-edit.el (widget-keymap): Don't bind [menu-bar] here. + (widget-field-keymap): Bind it here instead. + (widget-text-keymap): And here. + +Sun Feb 9 20:33:25 1997 Per Abrahamsen + + * widget-browse.el: New file. + * Makefile (WIDGET): Added it. + * widget.el (widget-browse-at): Added autoload. + (widget-browse): Ditto. + * widget-edit.el (widget-identify): Deleted. + + * custom-edit.el (custom-mode): Install custom-mode-menu under + XEmacs. + +Sat Feb 08 13:16:17 1997 Per Abrahamsen + + * Version 1.30 released. + +Sat Feb 8 13:15:21 1997 Per Abrahamsen + + * widget-edit.el (widget-name): New macro. + * widget.texi: Document it. + +Sat Feb 08 12:35:22 1997 Per Abrahamsen + + * Version 1.29 released. + +Sat Feb 8 12:29:48 1997 Per Abrahamsen + + * widget-edit.el (widget-get-sibling): New function. + (widget-identify): New command. + + * widget-edit.el (toggle): Don't use subwidgets. + (widget-toggle-convert-widget): Deleted. + (widget-toggle-value-create): New function. + (widget-toggle-action): New function. + (checkbox): Caller updated. + (radio-button): Ditto. + (boolean): Ditto. + * custom.el (custom-face-attributes): Ditto. + +Fri Feb 07 18:34:42 1997 Per Abrahamsen + + * Version 1.28 released. + +Fri Feb 7 18:33:47 1997 Per Abrahamsen + + * widget-edit.el (widget-keymap): Don't bind `C-a' and `C-e' + here. + (widget-field-keymap): Bind them here instead. + (widget-text-keymap): And here. + +Fri Feb 07 18:29:31 1997 Per Abrahamsen + + * Version 1.27 released. + +Fri Feb 7 18:18:31 1997 Per Abrahamsen + + * widget-edit.el (widget-beginning-of-line): New function. + (widget-keymap): Bind it. + Patch by "William M. Perry" . + (widget-end-of-line): New function. + (widget-keymap): Bind it. + +Thu Feb 06 19:21:09 1997 Per Abrahamsen + + * Version 1.26 released. + +Thu Feb 6 19:19:12 1997 Per Abrahamsen + + * widget-edit.el (widget-kill-line): New function. + (widget-keymap): Bind it. + +Thu Feb 06 19:10:37 1997 Per Abrahamsen + + * Version 1.25 released. + +Thu Feb 6 19:09:52 1997 Per Abrahamsen + + * widget-edit.el (widget-specify-field-update): Unconditionally + set local keymap property after the field. + +Sat Feb 01 13:13:48 1997 Per Abrahamsen + + * Version 1.24 released. + +Thu Jan 30 13:04:30 1997 Per Abrahamsen + + * widget-edit.el (widget-field-value-delete): Fix problem with + editable fields where the format string doesn't contain %v. + +Tue Jan 28 08:23:17 1997 Per Abrahamsen + + * Version 1.23 released. + +Tue Jan 28 04:33:24 1997 Per Abrahamsen + + * widget.el (:valid-regexp): New keyword. + * widget-edit.el (widget-field-validate): New function. + (editable-field): Use them. + * widget.texi (editable-field): Document it. + + * custom-edit.el (custom-face-format-handler): Removed unused + variable `state'. + + * custom.el (custom-menu-reset): Support menu-less XEmacs. + Reported by Carsten Leonhardt . + +Mon Jan 27 11:51:17 1997 Per Abrahamsen + + * Version 1.22 released. + +Mon Jan 27 08:46:05 1997 Per Abrahamsen + + * custom-edit.el (custom-variable-set): Fixed error message. + (custom-variable-save): Ditto. + + * Version 1.21 released. + +Mon Jan 27 07:17:55 1997 Per Abrahamsen + + * widget.el (:secret): New keyword. + * widget-edit.el (widget-specify-field-update): Support it. + (widget-field-value-get): Ditto. + * widget.texi (editable-field): Documented it. + + * widget-edit.el (widget-field-keymap): New variable. + (editable-field): Use it. + (widget-text-keymap): New variable. + (text): Use it. + (widget-field-activate): New command. + +Sun Jan 26 13:02:20 1997 Per Abrahamsen + + * custom.el (customize): Include `widgets' customization group. + +Sat Jan 25 08:23:02 1997 Per Abrahamsen + + * Version 1.20 released. + +Sat Jan 25 07:13:26 1997 Per Abrahamsen + + * widget-edit.el (widget-specify-field-update): Use + `widget-keymap' by default. + +Fri Jan 24 08:10:46 1997 Per Abrahamsen + + * Version 1.19 released. + +Fri Jan 24 06:53:48 1997 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): Typo in face name. + + * custom-edit.el (custom-variable-sample-face): New face. + (custom-variable-button-face): New face. + (custom-variable-value-create): Use them. + (custom-face-tag-face): New face. + (custom-face): Use it. + (custom-face-format-handler): Don't make the sample a button. + (custom-group-tag-faces): New variable. + (custom-group-tag-face-1): New face. + (custom-group-tag-face): New face. + (custom-group-sample-face-get): New function. + (custom-group): Use it. + + * widget-edit.el (character): Use sample face for tag. + (list): Ditto. + (vector): Ditto. + (cons): Ditto. + (radio): Ditto. + (repeat): Ditto. + (set): Ditto. + (boolean): Ditto. + +Thu Jan 23 20:25:46 1997 Per Abrahamsen + + * widget.el (:sample-face-get): New keyword. + (:sample-face): New keyword. + + * widget-edit.el (widget-default-create): Support %{ and %} + escapes. + (widget-specify-sample): New function. + (default): Define `:sample-face-get'. + (widget-default-sample-face-get): New function. + + * custom-edit.el (custom-variable-action): Show if hidden. + +Wed Jan 22 04:54:10 1997 Per Abrahamsen + + * widget-edit.el (error-message-string): Define if unbound. + +Thu Jan 16 16:07:09 1997 Per Abrahamsen + + * Version 1.18 released. + +Thu Jan 16 16:03:25 1997 Per Abrahamsen + + * custom-edit.el (custom-load-symbol): Use `assoc' instead of + `member' to check if a file is in load-history. + (custom-load-symbol): Use `condition-case' around loads. + +Tue Jan 14 20:51:37 1997 Per Abrahamsen + + * custom-edit.el (:custom-reset): Split into + :`custom-reset-current', `:custom-reset-saved', and + `:custom-reset-factory'. + (custom-mode-menu): Ditto. + (custom-mode): Ditto. + (custom-variable): Ditto. + (custom-variable-menu): Ditto. + (custom-face): Ditto. + (custom-face-menu): Ditto. + (custom-group): Ditto. + (custom-group-menu): Ditto. + (custom-group-reset): Ditto. + (custom-reset-menu): New variable. + (custom-reset): Use it. + (custom-reset-current): New function. + (custom-reset-saved): New function. + (custom-reset-factory): New function. + (custom-buffer-create): Pass event to `custom-reset'. + (custom-variable-reset-saved): Renamed from + `custom-variable-default'. + (custom-variable-reset-factory): Renamed from + `custom-variable-factory'. + (custom-face-reset-saved): Renamed from `custom-face-default'. + (custom-face-reset-factory): Renamed from + `custom-face-reset-factory'. + +Mon Jan 13 01:23:36 1997 Per Abrahamsen + + * Version 1.17 released. + +Mon Jan 13 00:19:35 1997 Per Abrahamsen + + * custom-edit.el (custom-face-format-handler): Missing "hide". + (custom-face-action): Show when hidden. + + * custom.texi: (The State Button): Updated. + +Wed Jan 8 15:23:29 1997 Per Abrahamsen + + * custom-edit.el (custom-quote): Support `characterp'. Patch + by Sudish Joseph . + + * custom-edit.el (custom-magic-alist): Refer to state button + instead of level button. + +Sat Jan 04 21:34:12 1997 Per Abrahamsen + + * Version 1.16 released. + +Fri Jan 3 22:56:57 1997 Per Abrahamsen + + * custom-edit.el (custom-group): Group tags are no longer buttons. + (custom-group-action): Show when hidden. + (custom-magic-value-create): Added :help-echo. + (custom-manual): Ditto. + * widget-edit.el (link): Ditto. + +Fri Jan 03 00:00:37 1997 Per Abrahamsen + + * Version 1.15 released. + +Thu Jan 2 23:30:43 1997 Per Abrahamsen + + * custom-edit.el (custom-magic): Can now contain multiple buttons. + (custom-magic-alist): Add description element. + (custom-magic-show): New variable. + (custom-magic-show-button): New variable. + (custom-magic-value-create): Use them. + (custom): Ditto. + (custom-variable): Ditto. + (custom-face): Ditto. + (widget-face-value-create): Ditto. + (custom-group): Ditto. + (custom-variable-value-create): Don't create [show] button. + (custom-variable-factory): Only save when saved. + (custom-face-factory): Ditto. + +Sat Dec 28 18:54:38 1996 Per Abrahamsen + + * Version 1.14 released. + +Sat Dec 28 13:43:44 1996 Per Abrahamsen + + * custom-edit.el: (custom-changed-face): New face. + (custom-magic-alist): New `changed' state. + (custom-variable-state-set): Support `set' state. + (custom-save): Ditto. + (custom-variable-set): Ditto. + (custom-variable-save): Ditto. + (custom-variable-default): Ditto. + (custom-variable-factory): Ditto. + (custom-face-state-set): Ditto. + (custom-face-set): Ditto. + (custom-face-save): Ditto. + (custom-face-default): Ditto. + (custom-face-factory): Ditto. + (custom-group-save): Ditto. + + * custom.texi (The State Button): Documented `changed' state. + + * custom-edit.el: New terminology: `Set default' automatically + saves the new value and has been renamed `Save'. `Apply' has been + renamed `Set'. `Edit Default' has been renamed to `Edit Lisp'. + * custom.texi: Ditto. + + * widget-edit.el (widget-move): New function. + (widget-forward): Use it. + (widget-backward): Ditto. + +Tue Dec 17 10:47:23 1996 Per Abrahamsen + + * custom-edit.el (custom-mode-menu): Added help item. + + * custom.texi (Declarations): New section. Documented `:tag' + keyword. + (Declaring Groups): Documented `:prefix' keyword. + + * custom-edit.el (custom-set-default): Also save. + (custom-buffer-create): Removed save button. + +Thu Dec 12 07:57:23 1996 Per Abrahamsen + + * widget-edit.el (widget-menu-max-size): Added `:group'. + + * custom-edit.el (custom-display): Added support for `pm', `pc', + and `win32' window systems. + + * widget-edit.el (widget-field-face): Do not require X. + +Tue Dec 10 13:28:22 1996 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): Green by default. + +Mon Dec 09 12:28:10 1996 Per Abrahamsen + + * Version 1.13 released. + +Mon Dec 9 08:50:46 1996 Per Abrahamsen + + * custom-edit.el (custom-unlispify-tag-names): New variable. + (custom-unlispify-tag-name): New function. + (custom-variable-value-create): Use it. + (custom-group-value-create): Use it. + (:custom-prefixes): New keyword. + (custom-variable-value-create): Use it. + (custom-group-value-create): Use it. + + * widget-edit.el (widget-item-convert-widget): Doc fix. + + * custom-edit.el (custom-menu-create): Do not create menus for + groups with more than `widget-menu-max-size' members. + +Sun Dec 08 16:19:21 1996 Per Abrahamsen + + * Version 1.12 released. + +Sun Dec 8 14:38:42 1996 Per Abrahamsen + + * custom.el (:tag): New keyword. + (custom-handle-keyword): Accept it. + + * custom.el (:prefix): New keyword. + (custom-declare-group): Handle it. + (customize): Use it. + * widget-edit.el (widgets): Use it. + + * custom-edit.el (custom-prefix-list): New variable. + (custom-unlispify-menu-entries): New variable. + (custom-unlispify-menu-entry): New function. + (custom-face-menu-create): Use it. + (custom-variable-menu-create): Use it. + (boolean): Use it. + (custom-menu-create): Use it. + + * custom-edit.el (custom-menu-create): New function. + (custom-group-menu-create): Use it. + +Thu Dec 5 14:00:04 1996 Per Abrahamsen + + * custom-opt.el: New file. + +Thu Dec 05 13:53:48 1996 Per Abrahamsen + + * Version 1.11 released. + +Thu Dec 5 13:22:31 1996 Per Abrahamsen + + * custom-edit.el (:custom-menu): New keyword. + (custom-variable): Use it. + (custom-face): Ditto. + (custom-group): Ditto. + (boolean): Ditto. + (custom-menu-update): Ditto. + (custom-face-menu-create): New function. + (custom-variable-menu-create): New function. + (custom-group-menu-create): New function. + (custom-menu-create-entry): Removed. + +Tue Dec 3 09:28:19 1996 Per Abrahamsen + + * custom.texi (Utilities): Documented `custom-add-load'. + +Tue Dec 03 08:42:15 1996 Per Abrahamsen + + * Version 1.10 released. + +Tue Dec 3 00:42:14 1996 Per Abrahamsen + + * custom-edit.el (custom-menu-nesting): Moved from `custom.el'. + (custom-menu-create-entry): Ditto. + (custom-menu-update): Ditto. + +Mon Dec 2 22:48:14 1996 Per Abrahamsen + + * custom.el (:load): New keyword. + (custom-add-load): New function. + (custom-handle-keyword): Use them. + * custom.texi: Document it. + * custom-edit.el (custom-load-symbol): New function. + (custom-load-widget): New function. + (custom-group-value-create): Use it. + (custom-variable-value-create): Use it. + (custom-face-value-create): Use it. + + * custom.el (custom-handle-keyword): New function. + (custom-declare-variable): Use it. + (custom-handle-all-keywords): New function. + (custom-declare-group): Use it. + (custom-declare-face): Use it. + +Sat Nov 30 01:37:07 1996 Per Abrahamsen + + * Version 1.09 released. + +Sat Nov 30 01:36:24 1996 Per Abrahamsen + + * widget-edit.el (widget-specify-field): Make terminating newline + writable under XEmacs. + +Thu Nov 28 22:03:56 1996 Per Abrahamsen + + * Version 1.08 released. + +Thu Nov 28 21:46:30 1996 Per Abrahamsen + + * custom-edit.el (custom-hook-convert-widget): Make space part of + function instead of the editable-list. + + * Version 1.07 released. + +Thu Nov 28 21:31:31 1996 Per Abrahamsen + + * custom-edit.el (custom-variable-state-set): Handle void + variables. + + * Version 1.06 released. + +Thu Nov 28 01:35:54 1996 Per Abrahamsen + + * widget-edit.el (widget-create-child-value): New function. + (widget-choice-value-create): Use it. + (widget-checklist-add-item): Ditto. + (widget-radio-add-item): Ditto. + (widget-editable-list-entry-create): Ditto + (widget-group-value-create): Ditto. + + * widget-edit.el (widget-specify-field): Extend read-only extent. + + * widget-edit.el (widget-create-child): Obey `:extra-offset'. + + * custom-edit.el (custom-mode-hook): Added. + +Tue Nov 26 17:04:45 1996 Per Abrahamsen + + * widget-edit.el: More patches for support of old Emacsen from + William Perry . + + * Version 1.05 released. + +Tue Nov 26 15:05:36 1996 Per Abrahamsen + + * widget-edit.el (widget-make-intangible): New function. + (widget-specify-field): Use it. + (widget-after-change): Remove XEmacs workaround. + (widget-field-value-create): Ditto. + (widget-specify-text): Fully specify stickyness. + +Mon Nov 25 17:01:05 1996 Per Abrahamsen + + * custom-edit.el (custom-face-format-handler): Create face before + use under XEmacs. + + * Version 1.04 released. + +Mon Nov 25 01:14:13 1996 Per Abrahamsen + + * custom.el (custom-facep): New function. + (custom-declare-face): Use it. + * custom-edit.el (customize-face): Ditto. + (customize-customized): Ditto. + (customize-apropos): Ditto. + (custom-save-faces): Ditto. + + * custom.el (custom-declare-variable): Return symbol. Suggested + by Lars Magne Ingebrigtsen . + (custom-declare-group): Ditto. + (custom-declare-face): Return face. + + * widget-edit.el (widget-button-face): Removed :link. + (widget-mouse-face): Ditto. + (widget-field-face): Ditto. + + * custom.el (emacs): Link to (emacs)Top, not (dir)Top. + + * Version 1.03 released. + +Mon Nov 25 00:29:27 1996 Per Abrahamsen + + * widget-edit.el (widgets): Add links. + (widget-button-face): Add link. + (widget-mouse-face): Add link. + (widget-field-face): Add link. + + * widget.texi (User Interface): Use `deffn Face' instead of + `defopt' for declaring faces. + + * custom-edit.el (custom-manual): New widget. + (custom-format-handler): Support "%a" escape. + (custom-variable): Use it. + (custom-face): Use it. + (custom-group): Use it. + + * custom.el (:link): New keyword. + (custom-declare-variable): Support it. + (custom-declare-face): Ditto. + (custom-declare-group): Ditto. + (emacs): Use it. + (customize): Ditto. + (custom-add-link): New function. + + * custom.texi (Utilities): New section. Document `custom-manual' + `custom-add-to-group', and `custom-add-link'. + + * widget.texi (url-link): New section. + (info-link): New section. + +Sat Nov 23 17:45:32 1996 Per Abrahamsen + + * Version 1.02 released. + +Sat Nov 23 17:42:31 1996 Per Abrahamsen + + * custom.el (set-face-font-family) New XEmacs function. + (custom-face-attributes): Added family support for XEmacs. + +Fri Nov 22 18:59:29 1996 Per Abrahamsen + + * Version 1.01 released. + +Fri Nov 22 16:29:08 1996 Per Abrahamsen + + * custom.el (custom-display-match-frame): Use `frame-device' to + convert a frame to a device. + + * widget-edit.el (widget-after-change): Avoid zero sized fields in + XEmacs. + (widget-field-value-create): Ditto. + + * custom.el (custom-face-display-set): Removed call to + `make-face'. Patch by David Moore . + (custom-declare-variable): If there is a saved value, use it, even + if the variable is already bound. Reported by Jens Lautenbacher + . + (custom-declare-face): If there is a saved face, use it, even + if the face is already made. + (custom-face-attributes): Added :size for XEmacs. Thanks to + William Perry for part of the code. + +Wed Nov 20 16:40:53 1996 Per Abrahamsen + + * custom-edit.el (custom-variable-value-create): Use + `default-value' instead of `symbol-value'. + (custom-variable-state-set): Ditto. + +Tue Nov 19 17:11:27 1996 Per Abrahamsen + + * widget-edit.el (custom): Wrap require in `eval-and-compile'. + +Mon Nov 18 15:55:16 1996 Per Abrahamsen + + * Version 1.00 released. + +Sat Nov 16 20:58:01 1996 Per Abrahamsen + + * custom.el (custom-help-menu): Renamed update entry to `Update + menu...'. + +Thu Nov 14 23:16:53 1996 Per Abrahamsen + + * custom-edit.el (customize-customized): Ignore uninitialized + faces and variables. + +Wed Nov 13 20:39:08 1996 Per Abrahamsen + + * Version 0.999 released. + +Wed Nov 13 12:21:56 1996 Per Abrahamsen + + * custom-edit.el: Added autolaod. + + * custom.el: Added menu support. + + * custom-edit.el (customize-customized): New command. + (custom-variable-default): Remember to evaluate default setting. + + * Version 0.998 released. + +Mon Nov 11 19:30:24 1996 Per Abrahamsen + + * widget-edit.el (widget-at): New function by William Perry + . + (widget-echo-help): Use it. + +Fri Nov 8 20:34:59 1996 Per Abrahamsen + + * widget-edit.el (widget-checklist-match-up): Cleaned up. + (function-item): Removed :match and :value-delete properties. + (variable-item): Ditto. + + * custom.el (custom-add-option): Only add option if not already + there. + (custom-declare-variable): Ditto. + + * custom-edit.el (custom-buffer-create): Reset magic. + +Thu Nov 07 16:14:35 1996 Per Abrahamsen + + * Version 0.997 released. + +Thu Nov 7 14:24:33 1996 Per Abrahamsen + + * custom-edit.el (custom-split-regexp-maybe): New function. + + * custom.el (x-color-values): Define if missing. + (frame-property): Define if missing. + (custom-background-mode): Optimized. + (custom-display-match-frame): Use above. + + * custom.el (custom-add-option): New function. + +Wed Nov 06 18:00:59 1996 Per Abrahamsen + + * Version 0.996 released. + +Wed Nov 6 09:42:33 1996 Per Abrahamsen + + * widget-edit.el (widget-children-value-delete): Renamed from + `widget-children-value-delete'. + Updated all callers. + (widget-choice-convert-widget): Renamed from `'. + + * custom-edit.el (widget-face-value-create): Add child to + `custom-options'. + (widget-face-value-delete): Added. + + * widget-edit.el (widget-keymap): Added binding for [backtab]. + Requested by Greg Stark . + +Sat Nov 2 13:40:49 1996 Per Abrahamsen + + + * custom.el (custom-set-variables): Accept `(SYMBOL VALUE [NOW])' + format. + (custom-set-faces): Accept `(FACE SPEC [NOW])' format. + * custom-edit.el (custom-save-variables): Write in new format. + (custom-save-faces): Ditto. + + * custom-edit.el (custom-format-handler): Handle `%L' escape. + (custom-group): Add `%L' escape. + (custom-face-format-handler): Use the text "hide" for sample in + shown faces. + (custom-buffer-create): Show single option. + +Tue Oct 29 13:36:11 1996 Per Abrahamsen + + * Version 0.995 released. + +Tue Oct 29 12:21:57 1996 Per Abrahamsen + + * custom.el (custom-display-match-frame): Fixed bug for + `display-type'. + + * custom.el (custom-background-mode): Memorized + `custom-background-mode' as suggested by David Moore + . + + * widget-edit.el (widget-specify-button): Make a button non-sticky + on XEmacs. + +Sun Oct 20 20:16:05 1996 Per Abrahamsen + + * custom-edit.el (easymenu): Added require. + +Mon Oct 14 15:09:43 1996 Per Abrahamsen + + * widget-edit.el: Removed `eval-and-compile' around compatibility + code. + +Sat Oct 12 21:15:04 1996 Per Abrahamsen + + * Version 0.994 released. + +Sat Oct 12 20:11:19 1996 Per Abrahamsen + + * custom.el (:options): New keyword. + + * widget-edit.el (hook): Removed widget. + (function): Allow any sexp. + + * custom-edit.el (hook): Added widget. + (custom-hook-convert-widget): New function. + + * custom.el (custom-declare-face): Check that facep is defined. + reported by Enami Tsugutomo + +Wed Oct 09 01:41:55 1996 Per Abrahamsen + + * Version 0.993 released. + +Tue Oct 8 01:48:02 1996 Per Abrahamsen + + * custom.el (custom-set-face-bold): Removed condition-case. + (custom-set-face-italic): Ditto. + (custom-face-attribites-set): Added condition-case. + (custom-set-variables): Do not bind symbol here. + (custom-set-faces): Do not create face here. + (custom-declare-variable): Use saved-value property, if is exists. + + * custom-edit.el (custom-face-format-handler): Changed `sample' to + `show'. + + * custom.el (custom-declare-face): Do not overwrite an existing + face. + +Sat Oct 05 01:23:27 1996 Per Abrahamsen + + * Version 0.992 released. + +Fri Oct 4 23:54:54 1996 Per Abrahamsen + + * widget-edit.el (character): New widget. + (widget-specify-field): Allow use of newline in format to hide + space. + +Wed Oct 2 19:06:17 1996 Per Abrahamsen + + * widget.texi (menu-choice): Document `:case-fold'. + +Wed Oct 02 19:02:45 1996 Per Abrahamsen + + * Version 0.991 released. + +Wed Oct 2 18:54:53 1996 Per Abrahamsen + + * widget-edit.el (widget-choice-action): Use :case-fold. + (menu-choice): Initialize :case-fold. + + * widget.el (:case-fold): New keyword, patch by David Byers + . + +Mon Sep 30 20:26:59 1996 Per Abrahamsen + + * lpath.el (maybe-fbind): New function. + Shut up byte compiler under XEmacs. + + * custom-edit.el (custom-format-handler): Removed unused binding. + (custom-variable-apply): Added missing argument to error. + (custom-variable-set-default): Ditto. + + * widget-edit.el (regexp): Add `:tag'. + + * custom-edit.el (custom-variable-factory): Evaluate factory + setting before applying. + +Sun Sep 29 01:24:31 1996 Per Abrahamsen + + * Version 0.99 released. + +Sun Sep 29 00:16:31 1996 Per Abrahamsen + + * widget-edit.el (widget-color-action): Notify parent. + (widget-field-action): Ditto. + (widget-choice-action): Ditto. + (widget-file-action): Ditto. + + * custom-edit.el (custom-magic-alist): Changed `item' to `const'. + (face): Fixed formatting. + (widget-face-value-create): Ditto. + (widget-face-action): Notify parent. + + * widget-edit.el (widget-field-value-get): Don't strip trailing + spaces from zero-sized fields. Requested by David Byers + . + +Sat Sep 28 00:31:54 1996 Per Abrahamsen + + * custom-edit.el (custom-save-needed-p): New variable. + (kill-emacs-hook): Add `custom-save-maybe'. + (custom-save-maybe): New function. + (custom-variable-set-default): Set `custom-save-needed-p'. + (custom-variable-factory): Ditto. + (custom-save): Ditto. + (custom-unimplemented): Deleted. + + * Version 0.98 released. + +Sat Sep 28 00:04:58 1996 Per Abrahamsen + + * widget-edit.el (widget-choice-action): Got validate wrong, once + again. + + * widget.texi (Basic Types): Documented `%h'. + +Fri Sep 27 00:32:14 1996 Per Abrahamsen + + * widget-edit.el (widget-field-action): Set value directly. + + * custom-edit.el (custom-format-handler): Use default format + handler. + + * widget-edit.el (widget-cons-match): Parameters in wrong order. + (text): Parent should be `editable-field'. + (widget-field-action): Call `widget-setup' after modification. + (symbol): Make multiple convertion kludge more robust. + (integer): Ditto. + (number): Ditto. + (widget-echo-help): New function, patch by William Perry + . + (widget-forward): Use it + (widget-echo-help-mouse): New function. + (repeat): Don't highlight tag. + (set): Ditto. + (widget-editable-list-format-handler): Default to help format + handler. + (function-item): Use default format handler. + (variable-item): Ditto. + (widget-help-format-handler): Rename to and merge with + `widget-default-format-handler'. + +Wed Sep 25 22:44:45 1996 Per Abrahamsen + + * Version 0.97 released. + +Wed Sep 25 00:12:09 1996 Per Abrahamsen + + * widget-edit.el (url-link): New widget. + + * custom-edit.el (custom-variable-set-default): Also set current + value. + + * lpath.el: Added dummy definitions to really shut up the byte + compiler. + + * custom-edit.el (custom-buffer-create): Create a help button. + + * widget-edit.el (info-link): New widget. + +Tue Sep 24 23:52:07 1996 Per Abrahamsen + + * custom.texi (The Customization Buffer): Exanded a lot. + +Mon Sep 23 18:27:55 1996 Per Abrahamsen + + * Makefile (FTPDIR): New variable. + (dist): Use it. + + * Version 0.96 released. + +Mon Sep 23 13:30:08 1996 Per Abrahamsen + + * widget.texi (editable-field): Added explanation of + :hide-front-space and :hide-rear-space. + + * widget-edit.el (widget-specify-field): Make front and rear + spaces intangible only when the :format string says it is safe, or + the user has explictly requested it. + + * widget.el (:hide-front-space): New keyword. + (:hide-rear-space): New keyword. + + * widget-edit.el (widget-field-value-create): Don't insert space + for empty values. + (widget-specify-field-update): Make null sized field have a face + that extents to the end of the line. + (widget-after-change): Make sure face is updated after extending a + fixed size field. + +Sun Sep 22 21:07:56 1996 Per Abrahamsen + + * Version 0.95 released. + +Sun Sep 22 13:44:02 1996 Per Abrahamsen + + * widget-edit.el (symbol): Kludge allowing multiple conversions. + (widget-field-value-create): Don't append spaces unless empty. + Suggested by David Byers . + (widget-field-value-get): Don't remove trailing spacesfor variable + sized fields. Suggested by David Byers . + + * custom-edit.el (custom-show): New function. + (custom-variable-value-create): Use it. + (editable-field): Only show when value has no newlines and is + shorter than 40 characters. + (custom-buffer-create): Use `switch-to-buffer' instead of + `switch-to-buffer-other-window'. + + * widget-edit.el: Added hack to make `widget-edit.el' useful even + with the old custom library. Suggested by David Byers + . + + * custom-edit.el (custom-help): Delete widget. + (custom-help-action): Delete function. + (:custom-doc): Delete keyword. + (:custom-documentation-property): Delete keyword. + (custom-format-handler): Leave `h' to `widget-help-format-handler'. + (custom): Replace `:custom-documentation-property' with + `:documentation-property'. + (custom-variable): Ditto. + (custom-face): Ditto. + (custom-group): Ditto. + + * widget-edit.el (widget-help): New widget. + (widget-help-action): New function. + (widget-help-format-handler): New function. + (function-item): New widget. + (variable-item): New widget. + (hook): New widget. + + * widget.el (:documentation-property): New keyword. + (:widget-doc): New keyword. + + * custom-edit.el (custom-variable-state-set): Compare value to + evaluted defaults. + + * widget-edit.el (radio): New sexp widget. + + * lpath.el (custom): Add require. + + * custom.el: (custom-face-empty): Test for `(boundp 'make-face)'. + Reported by enami tsugutomo . + (custom-face-display-set): Ditto. + + * lpath.el: Removed byte compiler kludge. + +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 23:17:22 1996 Per Abrahamsen + + * Version 0.94 released. + +Sat Sep 21 13:26:15 1996 Per Abrahamsen + + * custom-edit.el: Added `:custom-apply', `:custom-set-default', + and `:custom-reset' keywords. + (custom-variable): Bind above. + (custom-face): Ditto. + (custom-group): Ditto. + (custom-group-menu): Activate functions below. + (custom-group-apply): New function. + (custom-group-set-default): New function. + (custom-group-reset): New function. + (custom-mode-menu): New menu. + (custom-mode): Describe all commands. + (custom-mode): Added `custom-mode-hook' hook. + (custom-apply): New command. + (custom-set-default): New command. + (custom-reset): New command. + (custom-buffer-create): Set `custom-options' properly. + (custom-buffer-create): Add `apply', `Set Default', and `Reset' + butons. + + * custom.texi (Wishlist): Remove implemented items from the + wishlist. + + * widget.texi (atoms): Document `boolean' widget. + (composite): Document `choice', `set', and `repeat' widgets. + + * widget-edit.el (boolean): New sexp widget. + + * Version 0.93 released. + +Sat Sep 21 00:57:14 1996 Per Abrahamsen + + * lpath.el Disable byte compiler hacking on XEmacs. + + * Version 0.92 released. + +Fri Sep 20 03:04:53 1996 Per Abrahamsen + + * Added support for automatic indentation of nested widgets. + + * Made code and internal API creation of nested widget more + clear and less buggy. + + * Version 0.91 released. + +Thu Sep 19 19:30:46 1996 Per Abrahamsen + + * lpath.el: Add code to shut up the compiler. + + * widget.el (define-widget-keywords): Use this to shut up the + bytecompiler. + + * widget-edit.el: (widget-field-action): New function. + (field): Added. + (string, list, vector, cons): Added tag. + + * custom-edit.el (custom-magic): New widget. + Most other widgets and functions updated to support it. + (custom-notify): New function. + (custom): Use it. + (customize-apropos): Less greedy. Thanks Ilya + Zakharevich . + + * widget-edit.el (pp-to-string): Added autoload. Thanks Ilya + Zakharevich . + +Wed Sep 18 19:24:03 1996 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): New face. + (widget-specify-doc): Use it. + +Tue Sep 17 00:57:02 1996 Per Abrahamsen + + * widget-edit.el (item): Add "%d" to format. + (function): New widget. + (variable): New widget. + (regexp): New widget. + + * custom.el (custom-x-color-values): Stolen from Gnus. + (custom-background-mode): Stolen from Gnus. + (custom-display-match-frame): Should now work on XEmacs. + + * custom-edit.el: Minor cleanups in organization. + (custom-variable-value-create): Handle case where the value of a + variable does not match the type gracefully. + (custom-redraw): Renamed from `custom-reset'. + + * Version 0.9 released. + +Tue Sep 17 00:21:01 1996 Per Abrahamsen + + * widget-edit.el (widget-color-action): Use `read-prompt' in + XEmacs and `read-string' on a tty. + + * custom-edit.el (customize-apropos): Don't match undocumented + variables. + +Mon Sep 16 15:44:34 1996 Per Abrahamsen + + * custom-edit.el: Added help text to many widgets. + + * widget-edit.el (color-item): Made it a choice-item. + + * custom-edit.el (custom-level): New widget. + (custom-help): New widget. + (custom): New widget. + (custom-variable): Derive widget from `custom'. + (custom-face): Ditto. + (custom-group): Ditto. + + * widget-edit.el (widget-choose): Do not reverse the items here. + (widget-choice-action): Reverese the items here instead. + + * custom.el (keywords): Only define the keywords used by + declarations here. + + * widget-edit.el (toggle): Removed `:void' property. + + * custom.texi (Declaring Groups): Use proper defuns. + + * Makefile (TEXT): Added `ChangeLog' and `custom.texi'. + (dist): Add release to `ChangeLog'. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/custom/custom-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/custom-edit.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,1650 @@ +;;; custom-edit.el --- Tools for customization Emacs. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, faces +;; Version: 1.40 +;; 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) + (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) + (easy-menu-add custom-mode-menu) + (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 " ") + (widget-create 'push-button + :tag "Done" + :help-echo "Push me to bury the buffer." + :action (lambda (widget &optional event) + (bury-buffer))) + (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." + (let ((pos (point)) + (from (marker-position (widget-get widget :from))) + (to (marker-position (widget-get widget :to)))) + (save-excursion + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + (when (and (>= pos from) (<= pos to)) + (goto-char pos)))) + +(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)) + 'set + 'changed)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'changed)) + ((setq tmp (get symbol 'factory-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'factory + 'changed)) + (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 (capitalize + (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)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((eq form 'lisp) + (set symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) + (t + (set symbol (setq val (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)) + (goto-char (widget-get val :from)) + (error "%s" (widget-get val :error))) + ((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 + (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 (capitalize (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 (capitalize + (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 498bf5da1c90 -r 0d2f883870bc lisp/custom/custom.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/custom.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,583 @@ +;;; custom.el -- Tools for declaring and initializing options. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, faces +;; Version: 1.40 +;; 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 declare and initialize +;; user options. The code to customize options is autoloaded from +;; `custom-edit.el'. + +;;; Code: + +(require 'widget) + +(define-widget-keywords :prefix :tag :load :link :options :type :group) + +;; These autoloads should be deleted when the file is added to Emacs + +(unless (fboundp 'load-gc) + (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")) + +;;; Compatibility. + +(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)))) + +(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-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)) + +;; 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))) + +;;; The `defcustom' Macro. + +(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) + +(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]... + +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." + `(eval-and-compile + (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) + +;;; The `defface' Macro. + +(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) + +(defmacro defface (face spec doc &rest args) + "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." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) + +;;; The `defgroup' Macro. + +(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) + +(defmacro defgroup (symbol members doc &rest args) + "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." + `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) + +(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))))))) + +;;; Properties. + +(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-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-add-option (symbol option) + "To the variable SYMBOL add OPTION. + +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-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-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))))) + +;;; Face Utilities. + +(and (fboundp 'make-face) + (make-face 'custom-face-empty)) + +(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)))))) + +(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-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))) + +(defconst custom-face-attributes + '((:bold (toggle :format "Bold: %[%v%]\n") custom-set-face-bold) + (:italic (toggle :format "Italic: %[%v%]\n") custom-set-face-italic) + (:underline + (toggle :format "Underline: %[%v%]\n") 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. + +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. + +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.") + +(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 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 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))) + + (nconc custom-face-attributes + '((:family (editable-field :format "Family: %v") + set-face-font-family) + (:size (editable-field :format "Size: %v") + set-face-font-size)))) + +(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'. + +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-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-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-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)))))) + +;;; Initializing. + +(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]) + +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-set-faces (&rest args) + "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." + (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))))))) + +;;; Meta Customization + +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(emacs)Top")) + +(defgroup customize '((widgets custom-group)) + "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) + +(defcustom custom-define-hook nil + "Hook called after defining each customize option." + :group 'customize + :type 'hook) + +;;; Menu support + +(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") + +(defun custom-menu-reset () + "Reset customize menu." + (remove-hook 'custom-define-hook 'custom-menu-reset) + (cond ((fboundp 'add-submenu) + ;; XEmacs with menus. + (add-submenu '("Help") custom-help-menu)) + ((string-match "XEmacs" emacs-version) + ;; XEmacs without menus. + ) + (t + ;; Emacs. + (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))))))) + +(unless (fboundp 'load-gc) + (custom-menu-reset)) + +;;; The End. + +(provide 'custom) + +;; custom.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/custom/widget-browse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-browse.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,232 @@ +;;; widget-browse.el --- Functions for browsing widgets. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: extensions +;; Version: 1.40 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; Widget browser. See `widget.el'. + +;;; Code: + +(require 'easymenu) +(require 'custom) +(require 'widget-edit) +(require 'cl) + +(defgroup widget-browse nil + "Customization support for browsing widgets." + :group 'widgets) + +;;; The Mode. + +(defvar widget-browse-mode-map nil + "Keymap for `widget-browse-mode'.") + +(unless widget-browse-mode-map + (setq widget-browse-mode-map (make-sparse-keymap)) + (set-keymap-parent widget-browse-mode-map widget-keymap)) + +(easy-menu-define widget-browse-mode-menu + widget-browse-mode-map + "Menu used in widget browser buffers." + '("Widget" + ["Browse" widget-browse t] + ["Browse At" widget-browse-at t])) + +(defcustom widget-browse-mode-hook nil + "Hook called when entering widget-browse-mode." + :type 'hook + :group 'widget-browse) + +(defun widget-browse-mode () + "Major mode for widget browser 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. + +Entry to this mode calls the value of `widget-browse-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'widget-browse-mode + mode-name "Widget") + (use-local-map widget-browse-mode-map) + (easy-menu-add widget-browse-mode-menu) + (run-hooks 'widget-browse-mode-hook)) + +;;; Commands. + +;;;###autoload +(defun widget-browse-at (pos) + "Browse the widget under point." + (interactive "d") + (let* ((field (get-text-property pos 'field)) + (button (get-text-property pos 'button)) + (doc (get-text-property pos 'widget-doc)) + (text (cond (field "This is an editable text area.") + (button "This is an active area.") + (doc "This is documentation text.") + (t "This is unidentified text."))) + (widget (or field button doc))) + (when widget + (widget-browse widget)) + (message text))) + +(defvar widget-browse-history nil) + +(defun widget-browse (widget) + "Create a widget browser for WIDGET." + (interactive (list (completing-read "Widget: " + obarray + (lambda (symbol) + (get symbol 'widget-type)) + t nil 'widget-browse-history))) + (if (stringp widget) + (setq widget (intern widget))) + (unless (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (get (widget-type widget) 'widget-type))) + (error "Not a widget.")) + ;; Create the buffer. + (if (symbolp widget) + (let ((buffer (format "*Browse %s Widget*" widget))) + (kill-buffer (get-buffer-create buffer)) + (switch-to-buffer (get-buffer-create buffer))) + (kill-buffer (get-buffer-create "*Browse Widget*")) + (switch-to-buffer (get-buffer-create "*Browse Widget*"))) + (widget-browse-mode) + + ;; Quick way to get out. + (widget-create 'push-button + :action (lambda (widget &optional event) + (bury-buffer)) + "Quit") + (widget-insert "\n") + + ;; Top text indicating whether it is a class or object browser. + (if (listp widget) + (widget-insert "Widget object browser.\n\nClass: ") + (widget-insert "Widget class browser.\n\n") + (widget-create 'widget-browse + :format "%[%v%]\n%d" + :doc (get widget 'widget-documentation) + widget) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\nSuper: ") + (setq widget (get widget 'widget-type))) + + ;; Now show the attributes. + (let ((name (car widget)) + (items (cdr widget)) + key value printer) + (widget-create 'widget-browse + :format "%[%v%]" + name) + (widget-insert "\n") + (while items + (setq key (nth 0 items) + value (nth 1 items) + printer (or (get key 'widget-keyword-printer) + 'widget-browse-sexp) + items (cdr (cdr items))) + (widget-insert "\n" (symbol-name key) "\n\t") + (funcall printer widget key value) + (widget-insert "\n"))) + (widget-setup) + (goto-char (point-min))) + +;;; The `widget-browse' Widget. + +(define-widget 'widget-browse 'push-button + "Button for creating a widget browser. +The :value of the widget shuld be the widget to be browsed." + :format "%[[%v]%]" + :value-create 'widget-browse-value-create + :action 'widget-browse-action) + +(defun widget-browse-action (widget &optional event) + ;; Create widget browser for WIDGET's :value. + (widget-browse (widget-get widget :value))) + +(defun widget-browse-value-create (widget) + ;; Insert type name. + (let ((value (widget-get widget :value))) + (cond ((symbolp value) + (insert (symbol-name value))) + ((consp value) + (insert (symbol-name (widget-type value)))) + (t + (insert "strange"))))) + +;;; Keyword Printer Functions. + +(defun widget-browse-widget (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a widget." + (widget-create 'widget-browse value)) + +(defun widget-browse-widgets (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (while value + (widget-create 'widget-browse + (car value)) + (setq value (cdr value)) + (when value + (widget-insert " ")))) + +(defun widget-browse-sexp (widget key value) + "Insert description of WIDGET's KEY VALUE. +Nothing is assumed about value." + (let ((pp (condition-case signal + (pp-to-string value) + (error (prin1-to-string signal))))) + (when (string-match "\n\\'" pp) + (setq pp (substring pp 0 (1- (length pp))))) + (if (cond ((string-match "\n" pp) + nil) + ((> (length pp) (- (window-width) (current-column))) + nil) + (t t)) + (widget-insert pp) + (widget-create 'push-button + :tag "show" + :action (lambda (widget &optional event) + (with-output-to-temp-buffer + "*Pp Eval Output*" + (princ (widget-get widget :value)))) + pp)))) + +(defun widget-browse-sexps (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (let ((target (current-column))) + (while value + (widget-browse-sexp widget key (car value)) + (setq value (cdr value)) + (when value + (widget-insert "\n" (make-string target ?\ )))))) + +;;; Keyword Printers. + +(put :parent 'widget-keyword-printer 'widget-browse-widget) +(put :children 'widget-keyword-printer 'widget-browse-widgets) +(put :buttons 'widget-keyword-printer 'widget-browse-widgets) +(put :button 'widget-keyword-printer 'widget-browse-widget) +(put :args 'widget-keyword-printer 'widget-browse-sexps) + +;;; The End: + +(provide 'widget-browse) + +;; widget-browse.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/custom/widget-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-edit.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,2381 @@ +;;; widget-edit.el --- Functions for creating and using widgets. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: extensions +;; Version: 1.40 +;; 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) + (define-widget-keywords :prefix :tag :load :link :options :type :group) + (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) + (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. + +(defsubst 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 title + (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))))) + +(defun widget-get-sibling (widget) + "Get the item WIDGET is assumed to toggle. +This is only meaningful for radio buttons or checkboxes in a list." + (let* ((parent (widget-get widget :parent)) + (children (widget-get parent :children)) + child) + (catch 'child + (while children + (setq child (car children) + children (cdr children)) + (when (eq (widget-get child :button) widget) + (throw 'child child))) + nil))) + +;;; 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 (widget-get widget :keymap)) + (secret (widget-get widget :secret)) + (secret-to to) + (size (widget-get widget :size)) + (face (or (widget-get widget :value-face) + 'widget-field-face))) + + (when secret + (while (and size + (not (zerop size)) + (> secret-to from) + (eq (char-after (1- secret-to)) ?\ )) + (setq secret-to (1- secret-to))) + + (save-excursion + (goto-char from) + (while (< (point) secret-to) + (let ((old (get-text-property (point) 'secret))) + (when old + (subst-char-in-region (point) (1+ (point)) secret old))) + (forward-char)))) + + (set-text-properties from to (list 'field widget + 'read-only nil + 'keymap map + 'local-map map + 'face face)) + + (when secret + (save-excursion + (goto-char from) + (while (< (point) secret-to) + (let ((old (following-char))) + (subst-char-in-region (point) (1+ (point)) old secret) + (put-text-property (point) (1+ (point)) 'secret old)) + (forward-char)))) + + (unless (widget-get widget :size) + (add-text-properties to (1+ to) (list 'field widget + 'face face))) + (add-text-properties to (1+ to) (list '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. + +(defsubst widget-type (widget) + "Return the type of WIDGET, a symbol." + (car widget)) + +(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'." + (let ((missing t) + value tmp) + (while missing + (cond ((setq tmp (widget-plist-member (cdr widget) property)) + (setq value (car (cdr tmp)) + missing nil)) + ((setq tmp (car widget)) + (setq widget (get tmp 'widget-type))) + (t + (setq missing nil)))) + value)) + +(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))) + +;;; Glyphs. + +(defcustom widget-glyph-directory (concat data-directory "custom/") + "Where widget glyphs are located. +If this variable is nil, widget will try to locate the directory +automatically. This does not work yet." + :group 'widgets + :type 'directory) + +(defcustom widget-glyph-enable t + "If non nil, use glyphs in images when available." + :group 'widgets + :type 'boolean) + +(defun widget-glyph-insert (widget tag image) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should be a name sans extension of an xpm or xbm file located in +`widget-glyph-directory'" + (if (and (string-match "XEmacs" emacs-version) + widget-glyph-enable + (fboundp 'make-glyph) + image) + (let ((file (concat widget-glyph-directory + (if (string-match "/\\'" widget-glyph-directory) + "" + "/") + image + (if (featurep 'xpm) ".xpm" ".xbm")))) + (if (file-readable-p file) + (widget-glyph-insert-glyph widget tag (make-glyph file)) + ;; File not readable, give up. + (insert tag))) + ;; We don't want or can't use glyphs. + (insert tag))) + +(defun widget-glyph-insert-glyph (widget tag glyph) + "In WIDGET, with alternative text TAG, insert GLYPH." + (set-glyph-image glyph (cons 'tty tag)) + (set-glyph-property glyph 'widget widget) + (insert "*") + (add-text-properties (1- (point)) (point) + (list 'invisible t + 'end-glyph glyph))) + +;;; 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.") + +(unless widget-keymap + (setq widget-keymap (make-sparse-keymap)) + (define-key widget-keymap "\C-k" 'widget-kill-line) + (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)) + (progn + (define-key widget-keymap [button2] 'widget-button-click) + (define-key widget-keymap [button1] 'widget-button1-click)) + (define-key widget-keymap [mouse-2] 'ignore) + (define-key widget-keymap [down-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) + +(defvar widget-field-keymap nil + "Keymap used inside an editable field.") + +(unless widget-field-keymap + (setq widget-field-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-field-keymap [menu-bar] 'nil)) + (define-key widget-field-keymap "\C-m" 'widget-field-activate) + (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) + (define-key widget-field-keymap "\C-e" 'widget-end-of-line) + (set-keymap-parent widget-field-keymap global-map)) + +(defvar widget-text-keymap nil + "Keymap used inside a text field.") + +(unless widget-text-keymap + (setq widget-text-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-text-keymap [menu-bar] 'nil)) + (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) + (define-key widget-text-keymap "\C-e" 'widget-end-of-line) + (set-keymap-parent widget-text-keymap global-map)) + +(defun widget-field-activate (pos &optional event) + "Activate the ediable field at point." + (interactive "@d") + (let ((field (get-text-property pos 'field))) + (if field + (widget-apply field :action event) + (call-interactively + (lookup-key widget-global-map (this-command-keys)))))) + +(defun widget-button-click (event) + "Activate button below mouse pointer." + (interactive "@e") + (cond ((and (fboundp 'event-glyph) + (event-glyph event)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply widget :action event) + (message "You clicked on a glyph.")))) + ((event-point event) + (let ((button (get-text-property (event-point event) 'button))) + (if button + (widget-apply button :action event) + (call-interactively + (or (lookup-key widget-global-map [ button2 ]) + (lookup-key widget-global-map [ down-mouse-2 ]) + (lookup-key widget-global-map [ mouse-2])))))) + (t + (message "You clicked somewhere weird.")))) + +(defun widget-button1-click (event) + "Activate glyph below mouse pointer." + (interactive "@e") + (if (and (fboundp 'event-glyph) + (event-glyph event)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply widget :action event) + (message "You clicked on a glyph."))) + (call-interactively (lookup-key widget-global-map (this-command-keys))))) + +(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) + (let ((command (lookup-key widget-global-map (this-command-keys)))) + (when (commandp command) + (call-interactively command)))))) + +(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))) + +(defun widget-beginning-of-line () + "Go to beginning of field or beginning of line, whichever is first." + (interactive) + (let ((bol (save-excursion (beginning-of-line) (point))) + (prev (previous-single-property-change (point) 'field))) + (goto-char (max bol (or prev bol))))) + +(defun widget-end-of-line () + "Go to end of field or end of line, whichever is first." + (interactive) + (let ((bol (save-excursion (end-of-line) (point))) + (prev (next-single-property-change (point) 'field))) + (goto-char (min bol (or prev bol))))) + +(defun widget-kill-line () + "Kill to end of field or end of line, whichever is first." + (interactive) + (let ((field (get-text-property (point) 'field)) + (newline (save-excursion (search-forward "\n"))) + (next (next-single-property-change (point) 'field))) + (if (and field (> newline next)) + (kill-region (point) next) + (call-interactively 'kill-line)))) + +;;; 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)) + (glyph (widget-get widget :tag-glyph)) + (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) + (cond (glyph + (widget-glyph-insert widget (or tag "image") glyph)) + (tag + (insert tag)) + (t + (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. + +(defcustom widget-push-button-gui t + "If non nil, use GUI push buttons when available." + :group 'widgets + :type 'boolean) + +;; Cache already created GUI objects. +(defvar widget-push-button-cache nil) + +(define-widget 'push-button 'item + "A pushable button." + :value-create 'widget-push-button-value-create + :format "%[%v%]") + +(defun widget-push-button-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let* ((tag (or (widget-get widget :tag) + (widget-get widget :value))) + (text (concat "[" tag "]")) + (gui (cdr (assoc tag widget-push-button-cache)))) + (if (and (fboundp 'make-gui-button) + (fboundp 'make-glyph) + widget-push-button-gui + (string-match "XEmacs" emacs-version)) + (progn + (unless gui + (setq gui (make-gui-button tag 'widget-gui-action widget)) + (push (cons tag gui) widget-push-button-cache)) + (widget-glyph-insert-glyph widget text + (make-glyph (car (aref gui 1))))) + (insert text)))) + +(defun widget-gui-action (widget) + "Apply :action for WIDGET." + (widget-apply widget :action (this-command-keys))) + +;;; 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 + :keymap widget-field-keymap + :format "%v" + :value "" + :action 'widget-field-action + :validate 'widget-field-validate + :valid-regexp "" + :error "No match" + :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-validate (widget) + ;; Valid if the content matches `:valid-regexp'. + (save-excursion + (let ((value (widget-apply widget :value-get)) + (regexp (widget-get widget :valid-regexp))) + (if (string-match regexp value) + nil + widget)))) + +(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)) + ;; These are nil if the :format string doesn't contain `%v'. + (when (widget-get widget :value-from) + (set-marker (widget-get widget :value-from) nil)) + (when (widget-get widget :value-from) + (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)) + (secret (widget-get widget :secret)) + (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))) + (let ((result (buffer-substring-no-properties from to))) + (when secret + (let ((index 0)) + (while (< (+ from index) to) + (aset result index + (get-text-property (+ from index) 'secret)) + (setq index (1+ index))))) + (set-buffer old) + result)) + (widget-get widget :value)))) + +(defun widget-field-match (widget value) + ;; Match any string. + (stringp value)) + +;;; The `text' Widget. + +(define-widget 'text 'editable-field + :keymap widget-text-keymap + "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 'item + "Toggle between two states." + :format "%[%v%]\n" + :value-create 'widget-toggle-value-create + :action 'widget-toggle-action + :match (lambda (widget value) t) + :on "on" + :off "off") + +(defun widget-toggle-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (if (widget-value widget) + (widget-glyph-insert widget + (widget-get widget :on) + (widget-get widget :on-glyph)) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) + +(defun widget-toggle-action (widget &optional event) + ;; Toggle value. + (widget-value-set widget (not (widget-value widget))) + (widget-apply widget :notify widget event)) + +;;; The `checkbox' Widget. + +(define-widget 'checkbox 'toggle + "A checkbox toggle." + :format "%[%v%]" + :on "[X]" + :on-glyph "check1" + :off "[ ]" + :off-glyph "check0") + +;;; 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 + :format "%[%v%]" + :on "(*)" + :on-glyph "radio1" + :off "( )" + :off-glyph "radio0") + +(defun widget-radio-button-notify (widget child &optional event) + ;; Tell daddy. + (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. + +(defcustom widget-editable-list-gui nil + "If non nil, use GUI push-buttons in editable list when available." + :type 'boolean + :group 'widgets) + +(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. + (let ((widget-push-button-gui widget-editable-list-gui)) + (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))) + (widget-push-button-gui widget-editable-list-gui) + 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%]\n") + +;;; 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 498bf5da1c90 -r 0d2f883870bc lisp/custom/widget-example.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-example.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,93 @@ +;;; widget-example.el -- example of using the widget library + +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.40 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +(require 'widget) + +(eval-when-compile + (require 'widget-edit)) + +(defvar widget-example-repeat) + +(defun widget-example () + "Create the widgets from the Widget manual." + (interactive) + (switch-to-buffer "*Widget Example*") + (kill-all-local-variables) + (make-local-variable 'widget-example-repeat) + (let ((inhibit-read-only t)) + (erase-buffer)) + (widget-insert "Here is some documentation.\n\n") + (widget-create 'editable-field + :size 12 + :format "Name: %v " + "My Name") + (widget-create 'menu-choice + :tag "Choose" + :value "This" + :help-echo "Choose me, please!" + :notify (lambda (widget &rest ignore) + (message "%s is a good choice!" + (widget-value widget))) + '(item :tag "This option" :value "This") + '(choice-item "That option") + '(editable-field :menu-tag "No option" "Thus option")) + (widget-insert "Address: ") + (widget-create 'editable-field + "Some Place\nIn some City\nSome country.") + (widget-insert "\nSee also ") + (widget-create 'link + :notify (lambda (&rest ignore) + (widget-value-set widget-example-repeat + '("En" "To" "Tre")) + (widget-setup)) + "other work") + (widget-insert " for more information.\n\nNumbers: count to three below\n") + (setq widget-example-repeat + (widget-create 'editable-list + :entry-format "%i %d %v" + :notify (lambda (widget &rest ignore) + (let ((old (widget-get widget + ':example-length)) + (new (length (widget-value widget)))) + (unless (eq old new) + (widget-put widget ':example-length new) + (message "You can count to %d." new)))) + :value '("One" "Eh, two?" "Five!") + '(editable-field :value "three"))) + (widget-insert "\n\nSelect multiple:\n\n") + (widget-create 'checkbox t) + (widget-insert " This\n") + (widget-create 'checkbox nil) + (widget-insert " That\n") + (widget-create 'checkbox + :notify (lambda (&rest ignore) (message "Tickle")) + t) + (widget-insert " Thus\n\nSelect one:\n\n") + (widget-create 'radio-button-choice + :value "One" + :notify (lambda (widget &rest ignore) + (message "You selected %s" + (widget-value widget))) + '(item "One") '(item "Anthor One.") '(item "A Final One.")) + (widget-insert "\n") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (if (= (length (widget-value widget-example-repeat)) + 3) + (message "Congratulation!") + (error "Three was the count!"))) + "Apply Form") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (widget-example)) + "Reset Form") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/custom/widget.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,72 @@ +;;; widget.el --- a library of user interface components. +;; +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.40 +;; 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 :tag-glyph :off-glyph :on-glyph :valid-regexp + :secret :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 'widget-browse "widget-browse" nil t) +(autoload 'widget-browse-at "widget-browse" nil t) + +;;;###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 498bf5da1c90 -r 0d2f883870bc lisp/dired/ange-ftp.el --- a/lisp/dired/ange-ftp.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6074 +0,0 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs -;; Keywords: comm - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: ange-ftp.el -;; RCS: Header: ange-ftp.el,v 4.20 92/08/14 17:04:34 ange Exp -;; Description: transparent FTP support for GNU Emacs -;; Author: Andy Norman, ange@hplb.hpl.hp.com -;; Created: Thu Oct 12 14:00:05 1989 -;; Modified: Wed May 3 00:50:40 1995 (Andy Norman) ange@hplb.hpl.hp.com -;; Modified for XEmacs by jwz -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Copyright (C) 1989, 1990, 1991, 1992 Andy Norman. -;;; -;;; Author: Andy Norman (ange@hplb.hpl.hp.com) -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to ange@hplb.hpl.hp.com) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. - -;;; Synched up with: Not synched with FSF. - -;;; Description: -;;; -;;; This package attempts to make accessing files and directories using FTP -;;; from within GNU Emacs as simple and transparent as possible. A subset of -;;; the common file-handling routines are extended to interact with FTP. - -;;; Installation: -;;; -;;; Byte-compile ange-ftp.el to ange-ftp.elc and put them both in a directory -;;; on your load-path. Load the package from your .emacs file with: -;;; -;;; (require 'ange-ftp). -;;; -;;; ange-ftp can't sensibly be auto-loaded; you are either using it, or you -;;; ain't. - -;;; Usage: -;;; -;;; Some of the common GNU Emacs file-handling operations have been made -;;; FTP-smart. If one of these routines is given a filename that matches -;;; '/user@host:path' then it will spawn an FTP process connecting to machine -;;; 'host' as account 'user' and perform its operation on the file 'path'. -;;; -;;; For example: if find-file is given a filename of: -;;; -;;; /ange@anorman:/tmp/notes -;;; -;;; then ange-ftp will spawn an FTP process, connect to the host 'anorman' as -;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the -;;; contents of that file as if it were on the local filesystem. If ange-ftp -;;; needed a password to connect then it would prompt the user in the -;;; minibuffer. - -;;; Extended filename syntax: -;;; -;;; The default extended filename syntax is '/user@host:path', where the -;;; 'user@' part may be omitted. This syntax can be customised to a certain -;;; extent by changing ange-ftp-path-format. There are limitations. -;;; -;;; If the user part is omitted then ange-ftp will generate a default user -;;; instead whose value depends on the variable ange-ftp-default-user. - -;;; Passwords: -;;; -;;; A password is required for each host / user pair. This will be prompted -;;; for when needed, unless already set by calling ange-ftp-set-passwd, or -;;; specified in a *valid* ~/.netrc file. - -;;; Passwords for user "anonymous": -;;; -;;; Passwords for the user "anonymous" (or "ftp") are handled specially. The -;;; variable ange-ftp-generate-anonymous-password controls what happens: if -;;; the value of this variable is a string, then this is used as the password; -;;; if non-nil, then a password is created from the name of the user and the -;;; hostname of the machine on which GNU Emacs is running; if nil (the -;;; default) then the user is prompted for a password as normal. - -;;; "Dumb" UNIX hosts: -;;; -;;; The FTP servers on some UNIX machines have problems if the 'ls' command is -;;; used. -;;; -;;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to -;;; limit itself to the DIR command and not 'ls' for a given UNIX host. Note -;;; that this change will take effect for the current GNU Emacs session only. -;;; See below for a discussion of non-UNIX hosts. If a large number of -;;; machines with similar hostnames have this problem then it is easier to set -;;; the value of ange-ftp-dumb-unix-host-regexp in your .emacs file. ange-ftp -;;; is unable to automatically recognize dumb unix hosts. - -;;; File name completion: -;;; -;;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts. -;;; To do filename completion, ange-ftp needs a listing from the remote host. -;;; Therefore, for very slow connections, it might not save any time. - -;;; FTP processes: -;;; -;;; When ange-ftp starts up an FTP process, it leaves it running for speed -;;; purposes. Some FTP servers will close the connection after a period of -;;; time, but ange-ftp should be able to quietly reconnect the next time that -;;; the process is needed. -;;; -;;; The FTP process will be killed should the associated "*ftp user@host*" -;;; buffer be deleted. This should not cause ange-ftp any grief. - -;;; Binary file transfers: -;;; -;;; By default ange-ftp will transfer files in ASCII mode. If a file being -;;; transferred matches the value of ange-ftp-binary-file-name-regexp then the -;;; FTP process will be toggled into BINARY mode before the transfer and back -;;; to ASCII mode after the transfer. - -;;; Account passwords: -;;; -;;; Some FTP servers require an additional password which is sent by the -;;; ACCOUNT command. ange-ftp partially supports this by allowing the user to -;;; specify an account password by either calling ange-ftp-set-account, or by -;;; specifying an account token in the .netrc file. If the account password -;;; is set by either of these methods then ange-ftp will issue an ACCOUNT -;;; command upon starting the FTP process. - -;;; Preloading: -;;; -;;; ange-ftp can be preloaded, but must be put in the site-init.el file and -;;; not the site-load.el file in order for the documentation strings for the -;;; functions being overloaded to be available. - -;;; Status reports: -;;; -;;; Most ange-ftp commands that talk to the FTP process output a status -;;; message on what they are doing. In addition, ange-ftp can take advantage -;;; of the FTP client's HASH command to display the status of transferring -;;; files and listing directories. See the documentation for the variables -;;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and -;;; ange-ftp-process-verbose for more details. - -;;; Gateways: -;;; -;;; Sometimes it is neccessary for the FTP process to be run on a different -;;; machine than the machine running GNU Emacs. This can happen when the -;;; local machine has restrictions on what hosts it can access. -;;; -;;; ange-ftp has support for running the ftp process on a different (gateway) -;;; machine. The way it works is as follows: -;;; -;;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine -;;; that doesn't have the access restrictions. -;;; -;;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression -;;; that matches hosts that can be contacted from running a local ftp -;;; process, but fails to match hosts that can't be accessed locally. For -;;; example: -;;; -;;; "\\.hp\\.com$\\|^[^.]*$" -;;; -;;; will match all hosts that are in the .hp.com domain, or don't have an -;;; explicit domain in their name, but will fail to match hosts with -;;; explicit domains or that are specified by their ip address. -;;; -;;; 3) Using NFS and symlinks, make sure that there is a shared directory with -;;; the *same* name between the local machine and the gateway machine. -;;; This directory is neccessary for temporary files created by ange-ftp. -;;; -;;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of -;;; this directory plus an identifying filename prefix. For example: -;;; -;;; "/nfs/hplose/ange/ange-ftp" -;;; -;;; where /nfs/hplose/ange is a directory that is shared between the -;;; gateway machine and the local machine. -;;; -;;; The simplest way of getting a ftp process running on the gateway machine -;;; is if you can spawn a remote shell using either 'rsh' or 'remsh'. If you -;;; can't do this for some reason such as security then points 7 onwards will -;;; discuss an alternative approach. -;;; -;;; 5) Set the variable ange-ftp-gateway-program to the name of the remote -;;; shell process such as 'remsh' or 'rsh' if the default isn't correct. -;;; -;;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it -;;; isn't already. This tells ange-ftp that you are using a remote shell -;;; rather than logging in using telnet or rlogin. -;;; -;;; That should be all you need to allow ange-ftp to spawn a ftp process on -;;; the gateway machine. If you have to use telnet or rlogin to get to the -;;; gateway machine then follow the instructions below. -;;; -;;; 7) Set the variable ange-ftp-gateway-program to the name of the program -;;; that lets you log onto the gateway machine. This may be something like -;;; telnet or rlogin. -;;; -;;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular -;;; expression that matches the prompt you get when you login to the -;;; gateway machine. Be very specific here; this regexp must not match -;;; *anything* in your login banner except this prompt. -;;; shell-prompt-pattern is far too general as it appears to match some -;;; login banners from Sun machines. For example: -;;; -;;; "^$*$ *" -;;; -;;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let -;;; ange-ftp know that it has to "hand-hold" the login to the gateway -;;; machine. -;;; -;;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command -;;; that will put the pty connected to the gateway machine into a -;;; no-echoing mode, and will strip off carriage-returns from output from -;;; the gateway machine. For example: -;;; -;;; "stty -onlcr -echo" -;;; -;;; will work on HP-UX machines, whereas: -;;; -;;; "stty -echo nl" -;;; -;;; appears to work for some Sun machines. -;;; -;;; That's all there is to it. - -;;; Smart gateways: -;;; -;;; If you have a "smart" ftp program that allows you to issue commands like -;;; "USER foo@bar" which do nice proxy things, then look at the variables -;;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port. - -;;; Tips for using ange-ftp: -;;; -;;; 1. For dired to work on a host which marks symlinks with a trailing @ in -;;; an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t). -;;; Most UNIX systems do not do this, but ULTRIX does. If you think that -;;; there is a chance you might connect to an ULTRIX machine (such as -;;; prep.ai.mit.edu), then set this variable accordingly. This will have -;;; the side effect that dired will have problems with symlinks whose names -;;; end in an @. If you get youself into this situation then editing -;;; dired's ls-switches to remove "F", will temporarily fix things. -;;; -;;; 2. If you know that you are connecting to a certain non-UNIX machine -;;; frequently, and ange-ftp seems to be unable to guess its host-type, -;;; then setting the appropriate host-type regexp -;;; (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or -;;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report -;;; ange-ftp's inability to recognize the host-type as a bug. -;;; -;;; 3. For slow connections, you might get "listing unreadable" error -;;; messages, or get an empty buffer for a file that you know has something -;;; in it. The solution is to increase the value of ange-ftp-retry-time. -;;; Its default value is 5 which is plenty for reasonable connections. -;;; However, for some transatlantic connections I set this to 20. -;;; -;;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by -;;; copying the file to the local machine, compressing it there, and then -;;; sending it back. Binary file transfers between machines of different -;;; architectures can be a risky business. Test things out first on some -;;; test files. See "Bugs" below. Also, note that ange-ftp copies files by -;;; moving them through the local machine. Again, be careful when doing -;;; this with binary files on non-Unix machines. -;;; -;;; 5. Beware that dired over ftp will use your setting of dired-no-confirm -;;; (list of dired commands for which confirmation is not asked). You -;;; might want to reconsider your setting of this variable, because you -;;; might want confirmation for more commands on remote direds than on -;;; local direds. For example, I strongly recommend that you not include -;;; compress and uncompress in this list. If there is enough demand it -;;; might be a good idea to have an alist ange-ftp-dired-no-confirm of -;;; pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST -;;; is a list of commands for which confirmation would be suppressed. Then -;;; remote dired listings would take their (buffer-local) value of -;;; dired-no-confirm from this alist. Who votes for this? - -;;; --------------------------------------------------------------------- -;;; Non-UNIX support: -;;; --------------------------------------------------------------------- - -;;; VMS support: -;;; -;;; Ange-ftp has full support for VMS hosts, including tree dired support. It -;;; should be able to automatically recognize any VMS machine. However, if it -;;; fails to do this, you can use the command ange-ftp-add-vms-host. As well, -;;; you can set the variable ange-ftp-vms-host-regexp in your .emacs file. We -;;; would be grateful if you would report any failures to automatically -;;; recognize a VMS host as a bug. -;;; -;;; Filename Syntax: -;;; -;;; For ease of *implementation*, the user enters the VMS filename syntax in a -;;; UNIX-y way. For example: -;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -;;; would be entered as: -;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: -;;; [.CSV.POLICY]RULES.MEM -;;; you would type: -;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM -;;; -;;; A legal VMS filename is of the form: FILE.TYPE;## -;;; where FILE can be up to 39 characters -;;; TYPE can be up to 39 characters -;;; ## is a version number (an integer between 1 and 32,767) -;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ -;;; $ cannot begin a filename, and - cannot be used as the first or last -;;; character. -;;; -;;; Tips: -;;; 1. Although VMS is not case sensitive, EMACS running under UNIX is. -;;; Therefore, to access a VMS file, you must enter the filename with upper -;;; case letters. -;;; 2. To access the latest version of file under VMS, you use the filename -;;; without the ";" and version number. You should always edit the latest -;;; version of a file. If you want to edit an earlier version, copy it to a -;;; new file first. This has nothing to do with ange-ftp, but is simply -;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is -;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you -;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find -;;; that VMS will not allow you to save the file because it will refuse to -;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and -;;; attach the buffer to this file. To get out of this situation, M-x -;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to -;;; latest version of the file. For this reason, in tree dired "f" -;;; (dired-find-file), always loads the file sans version, whereas "v", -;;; (dired-view-file), always loads the explicit version number. The -;;; reasoning being that it reasonable to view old versions of a file, but -;;; not to edit them. -;;; 3. EMACS has a feature in which it does environment variable substitution -;;; in filenames. Therefore, to enter a $ in a filename, you must quote it -;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the -;;; $'s in the default directory when it writes it in the minibuffer. You -;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug -;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 -;;; or newer), you will not have this problem. - -;;; MTS support: -;;; -;;; Ange-ftp has full support, including tree dired support, for hosts running -;;; the Michigan terminal system. It should be able to automatically -;;; recognize any MTS machine. However, if it fails to do this, you can use -;;; the command ange-ftp-add-mts-host. As well, you can set the variable -;;; ange-ftp-mts-host-regexp in your .emacs file. We would be grateful if you -;;; would report any failures to automatically recognize a MTS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; MTS filenames are entered in a UNIX-y way. For example, if your account -;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be -;;; entered as -;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE -;;; In other words, MTS accounts are treated as UNIX directories. Of course, -;;; to access a file in another account, you must have access permission for -;;; it. If FILE were in your own account, then you could enter it in a -;;; relative path fashion as -;;; /YYYY@mtsg.ubc.ca:FILE -;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the -;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you -;;; like.) MTS filenames are always in upper case, and hence be sure to enter -;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX -;;; is. - -;;; CMS support: -;;; -;;; Ange-ftp has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; However, if it fails to do this, you can use the command -;;; ange-ftp-add-cms-host. As well, you can set the variable -;;; ange-ftp-cms-host-regexp in your .emacs file. We would be grateful if you -;;; would report any failures to automatically recognize a CMS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are -;;; treated as UNIX directories. For example to access the file READ.ME in -;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter -;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME -;;; If *.301 is the default minidisk for this account, you could access -;;; FOO.BAR on this minidisk as -;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR -;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be -;;; up to 8 characters. Again, beware that CMS filenames are always upper -;;; case, and hence must be entered as such. -;;; -;;; Tips: -;;; 1. CMS machines, with the exception of anonymous accounts, nearly always -;;; need an account password. To have ange-ftp send an account password, -;;; you can either include it in your .netrc file, or use -;;; ange-ftp-set-account. -;;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we -;;; can fix this. -;;; -;;; ------------------------------------------------------------------ -;;; Bugs: -;;; ------------------------------------------------------------------ -;;; -;;; 1. Umask problems: -;;; Be warned that files created by using ange-ftp will take account of the -;;; umask of the ftp daemon process rather than the umask of the creating -;;; user. This is particularly important when logging in as the root user. -;;; The way that I tighten up the ftp daemon's umask under HP-UX is to make -;;; sure that the umask is changed to 027 before I spawn /etc/inetd. I -;;; suspect that there is something similar on other systems. -;;; -;;; 2. Some combinations of FTP clients and servers break and get out of sync -;;; when asked to list a non-existent directory. Some of the ai.mit.edu -;;; machines cause this problem for some FTP clients. Using -;;; ange-ftp-kill-process can be used to restart the ftp process, which -;;; should get things back in synch. -;;; -;;; 3. Ange-ftp does not check to make sure that when creating a new file, -;;; you provide a valid filename for the remote operating system. -;;; If you do not, then the remote FTP server will most likely -;;; translate your filename in some way. This may cause ange-ftp to -;;; get confused about what exactly is the name of the file. The -;;; most common causes of this are using lower case filenames on systems -;;; which support only upper case, and using filenames which are too -;;; long. -;;; -;;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons. -;;; -;;; 5. Ange-ftp likes to use pty's to talk to its FTP processes. If GNU Emacs -;;; for some reason creates a FTP process that only talks via pipes then -;;; ange-ftp won't be getting the information it requires at the time that -;;; it wants it since pipes flush at different times to pty's. One -;;; disgusting way around this problem is to talk to the FTP process via -;;; rlogin which does the 'right' things with pty's. -;;; -;;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't -;;; worried about this too much. Eventually, we should have some caching -;;; of the current minidisk. -;;; -;;; 7. Some CMS machines do not assign a default minidisk when you ftp them as -;;; anonymous. It is then necessary to guess a valid minidisk name, and cd -;;; to it. This is (understandably) beyond ange-ftp. -;;; -;;; 8. Remote to remote copying of files on non-Unix machines can be risky. -;;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp -;;; will use binary mode for the copy. Between systems of different -;;; architecture, this still may not be enough to guarantee the integrity -;;; of binary files. Binary file transfers from VMS machines are -;;; particularly problematical. Should ange-ftp-binary-file-name-regexp be -;;; an alist of OS type, regexp pairs? -;;; -;;; 9. The code to do compression of files over ftp is not as careful as it -;;; should be. It deletes the old remote version of the file, before -;;; actually checking if the local to remote transfer of the compressed -;;; file succeeds. Of course to delete the original version of the file -;;; after transferring the compressed version back is also dangerous, -;;; because some OS's have severe restrictions on the length of filenames, -;;; and when the compressed version is copied back the "-Z" or ".Z" may be -;;; truncated. Then, ange-ftp would delete the only remaining version of -;;; the file. Maybe ange-ftp should make backups when it compresses files -;;; (of course, the backup "~" could also be truncated off, sigh...). -;;; Suggestions? -;;; - -;;; 10. If a dir listing is attempted for an empty directory on (at least -;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and -;;; I don't know how to get ange-ftp work to around it. -;;; -;;; 11. Bombs on filenames that start with a space. Deals well with filenames -;;; containing spaces, but beware that the remote ftpd may not like them -;;; much. -;;; -;;; 12. No classic dired support for non-UNIX systems. Tree dired was enough. -;;; -;;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks -;;; with a trailing @ in a ls -alF listing. In order to account for this -;;; ange-ftp looks to chop trailing @'s off of symlink names when it is -;;; parsing a listing with the F switch. This will cause ange-ftp to -;;; incorrectly get the name of a symlink on a non-ULTRIX host if its name -;;; ends in an @. ange-ftp will correct itself if you take F out of the -;;; dired ls switches (C-u s will allow you to edit the switches). The -;;; dired buffer will be automatically reverted, which will allow ange-ftp -;;; to fix its files hashtable. A cookie to anyone who can think of a -;;; fast, sure-fire way to recognize ULTRIX over ftp. - -;;; If you find any bugs or problems with this package, PLEASE either e-mail -;;; the above author, or send a message to the ange-ftp-lovers mailing list -;;; below. Ideas and constructive comments are especially welcome. - -;;; ange-ftp-lovers: -;;; -;;; ange-ftp has its own mailing list modestly called ange-ftp-lovers. All -;;; users of ange-ftp are welcome to subscribe (see below) and to discuss -;;; aspects of ange-ftp. New versions of ange-ftp are posted periodically to -;;; the mailing list. -;;; -;;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the -;;; list, please mail one of the following addresses: -;;; -;;; ange-ftp-lovers-request@anorman.hpl.hp.com -;;; or -;;; ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Please don't forget the -request part. -;;; -;;; For mail to be posted directly to ange-ftp-lovers, send to one of the -;;; following addresses: -;;; -;;; ange-ftp-lovers@anorman.hpl.hp.com -;;; or -;;; ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Alternatively, there is a mailing list that only gets announcements of new -;;; ange-ftp releases. This is called ange-ftp-lovers-announce, and can be -;;; subscribed to by e-mailing to the -request address as above. Please make -;;; it clear in the request which mailing list you wish to join. - -;;; The latest version of ange-ftp can usually be obtained via anonymous ftp -;;; from: -;;; alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.Z -;;; or: -;;; ugle.unit.no:/pub/gnu/emacs-lisp/ange-ftp.tar.Z -;;; or: -;;; archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/packages/ange-ftp.tar.Z - -;;; The archives for ange-ftp-lovers can be found via anonymous ftp under: -;;; -;;; ftp.reed.edu:pub/mailing-lists/ange-ftp/ - -;;; ----------------------------------------------------------- -;;; Technical information on this package: -;;; ----------------------------------------------------------- - -;;; The following GNU Emacs functions are replaced by this package: -;;; -;;; write-region -;;; insert-file-contents -;;; dired-readin -;;; dired-revert -;;; dired-call-process -;;; diff -;;; delete-file -;;; read-file-name-internal -;;; verify-visited-file-modtime -;;; directory-files -;;; backup-buffer -;;; file-directory-p -;;; file-writable-p -;;; file-exists-p -;;; file-readable-p -;;; file-symlink-p -;;; file-attributes -;;; copy-file -;;; rename-file -;;; file-name-as-directory -;;; file-name-directory -;;; file-name-nondirectory -;;; file-name-completion -;;; directory-file-name -;;; expand-file-name -;;; file-name-all-completions - -;;; LISPDIR ENTRY for the Elisp Archive -;;; -;;; LCD Archive Entry: -;;; ange-ftp|Andy Norman|ange@hplb.hpl.hp.com -;;; |transparent FTP Support for GNU Emacs -;;; |Date: 92/08/14 17:04:34 |Revision: 4.20 | - -;;; Checklist for adding non-UNIX support for TYPE -;;; -;;; The following functions may need TYPE versions: -;;; (not all functions will be needed for every OS) -;;; -;;; ange-ftp-fix-path-for-TYPE -;;; ange-ftp-fix-dir-path-for-TYPE -;;; ange-ftp-TYPE-host -;;; ange-ftp-TYPE-add-host -;;; ange-ftp-parse-TYPE-listing -;;; ange-ftp-TYPE-delete-file-entry -;;; ange-ftp-TYPE-add-file-entry -;;; ange-ftp-TYPE-file-name-as-directory -;;; -;;; Variables: -;;; -;;; ange-ftp-TYPE-host-regexp -;;; May need to add TYPE to ange-ftp-dumb-host-types -;;; -;;; Check the following functions for OS dependent coding: -;;; -;;; ange-ftp-host-type -;;; ange-ftp-guess-host-type -;;; ange-ftp-allow-child-lookup -;;; -;;; For Tree Dired support: -;;; -;;; ange-ftp-dired-TYPE-insert-headerline -;;; ange-ftp-dired-TYPE-move-to-filename -;;; ange-ftp-dired-TYPE-move-to-end-of-filename -;;; ange-ftp-dired-TYPE-get-filename -;;; ange-ftp-dired-TYPE-between-files -;;; ange-ftp-TYPE-make-compressed-filename -;;; ange-ftp-dired-TYPE-ls-trim -;;; ange-ftp-TYPE-bob-version -;;; ange-ftp-dired-TYPE-clean-directory -;;; ange-ftp-dired-TYPE-flag-backup-files -;;; ange-ftp-dired-TYPE-backup-diff -;;; -;;; Variables for dired: -;;; -;;; ange-ftp-dired-TYPE-re-exe -;;; ange-ftp-dired-TYPE-re-dir - -;;; Host type conventions: -;;; -;;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type -;;; (mostly) follow the following conventions for remote host types. At -;;; least, I think that future code should try to follow these conventions, -;;; and the current code should eventually be made compliant. -;;; -;;; nil = local host type, whatever that is (probably unix). -;;; Think nil as in "not a remote host". This value is used by -;;; ange-ftp-dired-host-type for local buffers. -;;; -;;; t = a remote host of unknown type. Think t is in true, it's remote. -;;; Currently, 'unix is used as the default remote host type. -;;; Maybe we should use t. -;;; -;;; 'type = a remote host of TYPE type. -;;; -;;; 'type:list = a remote host of TYPE type, using a specialized ftp listing -;;; program called list. This is currently only used for Unix -;;; dl (descriptive listings), when ange-ftp-dired-host-type -;;; is set to 'unix:dl. - -;;; Bug report codes: -;;; -;;; Because of their naive faith in this code, there are certain situations -;;; which the writers of this program believe could never happen. However, -;;; being realists they have put calls to 'error in the program at these -;;; points. These errors provide a code, which is an integer, greater than 1. -;;; To aid debugging the error codes, and the functions in which they reside -;;; are listed below. -;;; -;;; 1: See ange-ftp-ls -;;; - -;;; XEmacs changes from 4.20 -;;; -;;; - added gzip support -;;; - added "lazy" messages -;;; - fixed completion list in the root dir (nil vs (nil)) -;;; - use (message nil) to repaint minibuf instead of that awful kludge -;;; - call compute-buffer-file-truename to set truenames properly for -;;; when find-file-compare-truenames is set -;;; - make-directory takes a second optional argument -;;; - made ange-ftp-overwrite-fn use the 19.8 interface to byte-code objects -;;; - made ange-ftp-shell-mode work better with the latest comint -;;; - insert-file-contents takes 2-5 args in v19 -;;; - moved invocation of shell-mode to get along with the latest shell-font.el -;;; - implemented ange-ftp-read-passwd in terms of read-passwd (from passwd.el) -;;; - initialize all buffer-local variables to nil -;;; - Apollo stuff from Bob Weiner - - -;;; ----------------------------------------------------------- -;;; Hall of fame: -;;; ----------------------------------------------------------- -;;; -;;; Thanks to Roland McGrath for improving the filename syntax handling, -;;; for suggesting many enhancements and for numerous cleanups to the code. -;;; -;;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways. -;;; -;;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and -;;; dired / shell auto-loading. -;;; -;;; Thanks to Sebastian Kremer for tree dired support and for many ideas and -;;; bugfixes. -;;; -;;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support, -;;; VOS support, and hostname completion. -;;; -;;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help -;;; with file-name expansion, efficiency worries, stylistic concerns and many -;;; bugfixes. -;;; -;;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS, -;;; MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and -;;; auto-recognition of the host type. -;;; -;;; Thanks to Dave Smith who wrote the info file for ange-ftp. -;;; -;;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping -;;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann, -;;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill -;;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay -;;; Mathur, the folks on the ange-ftp-lovers mailing list and many others -;;; whose names I've forgotten who have helped to debug and fix problems with -;;; ange-ftp.el. - -;;;; ------------------------------------------------------------ -;;;; User customization variables. -;;;; ------------------------------------------------------------ - -;;;###autoload -(defvar ange-ftp-path-format - '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" . (3 2 4)) - "*Format of a fully expanded remote pathname. This is a cons -\(REGEXP . \(HOST USER PATH\)\), where REGEXP is a regular expression matching -the full remote pathname, and HOST, USER, and PATH are the numbers of -parenthesized expressions in REGEXP for the components (in that order).") - -;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of -;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs. -;; Otherwise, ange-ftp will go into multi-skip mode, and never come out. - -;; XEmacs patch from Bob Weiner -(defvar ange-ftp-multi-msgs - "^331-\\|^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^530-\\|^4[25]1-" - "*Regular expression matching messages from the ftp process that start -a multiline reply.") - -(defvar ange-ftp-good-msgs - "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark" - "*Regular expression matching messages from the ftp process that indicate -that the action that was initiated has completed successfully.") - -;; CMS and the odd VMS machine say 200 Port rather than 200 PORT. -;; Also CMS machines use a multiline 550- reply to say that you -;; don't have write permission. ange-ftp gets into multi-line skip -;; mode and hangs. Have it ignore 550- instead. It will then barf -;; when it gets the 550 line, as it should. - -(defvar ange-ftp-skip-msgs - (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|" - "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|" - "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye") - "*Regular expression matching messages from the ftp process that can be -ignored.") - -(defvar ange-ftp-fatal-msgs - (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|" - "^No control connection\\|unknown host\\|^lost connection") - "*Regular expression matching messages from the FTP process that indicate -something has gone drastically wrong attempting the action that was -initiated and that the FTP process should (or already has) been killed.") - -(defvar ange-ftp-gateway-fatal-msgs - "No route to host\\|Connection closed\\|No such host\\|Login incorrect" - "*Regular expression matching messages from the rlogin / telnet process that -indicates that logging in to the gateway machine has gone wrong.") - -(defvar ange-ftp-xfer-size-msgs - "^150 .* connection for .* (\\([0-9]+\\) bytes)" - "*Regular expression used to determine the number of bytes in a FTP transfer.") - -(defvar ange-ftp-tmp-name-template "/tmp/ange-ftp" - "*Template used to create temporary files.") - -(defvar ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp" - "*Template used to create temporary files when ftp-ing through a gateway. -Files starting with this prefix need to be accessible from BOTH the local -machine and the gateway machine, and need to have the SAME name on both -machines, that is, /tmp is probably NOT what you want, since that is rarely -cross-mounted.") - -(defvar ange-ftp-netrc-filename "~/.netrc" - "*File in .netrc format to search for passwords.") - -(defvar ange-ftp-disable-netrc-security-check nil - "*If non-nil avoid checking permissions on the .netrc file.") - -(defvar ange-ftp-default-user "anonymous" - "*User name to use when none is specied in a pathname. -If nil, then the name under which the user is logged in is used. -If non-nil but not a string, the user is prompted for the name.") - -(defvar ange-ftp-default-password nil - "*Password to use when the user is the same as ange-ftp-default-user.") - -(defvar ange-ftp-default-account nil - "*Account password to use when the user is the same as ange-ftp-default-user.") - -(defvar ange-ftp-generate-anonymous-password t ;; changed wing@666.com - "*If t, use a password of user@host when logging in as the anonymous user. -If a string then use that as the password. -If nil then prompt the user for a password.") - -(defvar ange-ftp-dumb-unix-host-regexp nil - "*If non-nil, if the host being ftp'd to matches this regexp then the FTP -process uses the \'dir\' command to get directory information.") - -(defvar ange-ftp-binary-file-name-regexp - (concat "\\.g?z$\\|\\.Z$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" - "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|" - "\\.EXE\\(;[0-9]+\\)?$\\|\\.g?z-part-..$\\|\\.Z-part-..$") - "*If a file matches this regexp then it is transferred in binary mode.") - -(defvar ange-ftp-gateway-host nil - "*Name of host to use as gateway machine when local FTP isn't possible.") - -(defvar ange-ftp-local-host-regexp ".*" - "*If a host being FTP'd to matches this regexp then the ftp process is started -locally, otherwise the FTP process is started on \`ange-ftp-gateway-host\' -instead.") - -(defvar ange-ftp-gateway-program-interactive nil - "*If non-nil then the gateway program is expected to connect to the gateway -machine and eventually give a shell prompt. Both telnet and rlogin do something -like this.") - -(defvar ange-ftp-gateway-program (if (eq system-type 'hpux) "remsh" "rsh") - "*Name of program to spawn a shell on the gateway machine. Valid candidates -are rsh (remsh on hp-ux), telnet and rlogin. See also the gateway variable -above.") - -(defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect that the logging-in sequence is completed on the -gateway machine and that the shell is now awaiting input. Make this regexp as -strict as possible; it shouldn't match *anything* at all except the user's -initial prompt. The above string will fail under most SUN-3's since it -matches the login banner.") - -(defvar ange-ftp-gateway-setup-term-command - (if (eq system-type 'hpux) - "stty -onlcr -echo\n" - "stty -echo nl\n") - "*Command to use after logging in to the gateway machine to stop the terminal -echoing each command and to strip out trailing ^M characters.") - -(defvar ange-ftp-smart-gateway nil - "*If the gateway FTP is smart enough to use proxy server, then don't bother -telnetting etc, just issue a user@host command instead.") - -(defvar ange-ftp-smart-gateway-port "21" - "*Port on gateway machine to use when smart gateway is in operation.") - -(defvar ange-ftp-send-hash t - "*If non-nil, send the HASH command to the FTP client.") - -(defvar ange-ftp-binary-hash-mark-size nil - "*Default size, in bytes, between hash-marks when transferring a binary file. -If NIL, this variable will be locally overridden if the FTP client outputs a -suitable response to the HASH command. If non-NIL then this value takes -precedence over the local value.") - -(defvar ange-ftp-ascii-hash-mark-size 1024 - "*Default size, in bytes, between hash-marks when transferring an ASCII file. -This variable is buffer-local and will be locally overridden if the FTP client -outputs a suitable response to the HASH command.") - -(defvar ange-ftp-process-verbose t - "*If non-NIL then be chatty about interaction with the FTP process.") - -(defvar ange-ftp-ftp-program-name "ftp" - "*Name of FTP program to run.") - -(defvar ange-ftp-gateway-ftp-program-name "ftp" - "*Name of FTP program to run on gateway machine. -Some AT&T folks claim to use something called `pftp' here.") - -(defvar ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v") - "*A list of arguments passed to the FTP program when started.") - -(defvar ange-ftp-nslookup-program nil - "*If non-NIL then a string naming nslookup program." ) - -(defvar ange-ftp-make-backup-files () - "*A list of operating systems for which ange-ftp will make Emacs backup -files on the remote host. For example, '\(unix\) makes sense, but -'\(unix vms\) or '\(vms\) would be silly, since vms makes its own backups.") - -(defvar ange-ftp-retry-time 5 - "*Number of seconds to wait before retrying if a file or listing -doesn't arrive. This might need to be increased for very slow connections.") - -(defvar ange-ftp-auto-save 0 - "If 1, allows ange-ftp files to be auto-saved. -If 0, suppresses auto-saving of ange-ftp files. -Don't use any other value.") - -;;;; ------------------------------------------------------------ -;;;; Hash table support. -;;;; ------------------------------------------------------------ - -(require 'backquote) - -(defun ange-ftp-make-hashtable (&optional size) - "Make an obarray suitable for use as a hashtable. -SIZE, if supplied, should be a prime number." - (make-vector (or size 31) 0)) - -(defun ange-ftp-map-hashtable (fun tbl) - "Call FUNCTION on each key and value in HASHTABLE." - (mapatoms - (function - (lambda (sym) - (funcall fun (get sym 'key) (get sym 'val)))) - tbl)) - -(defmacro ange-ftp-make-hash-key (key) - "Convert KEY into a suitable key for a hashtable." - (` (if (stringp (, key)) - (, key) - (prin1-to-string (, key))))) - -(defun ange-ftp-get-hash-entry (key tbl) - "Return the value associated with KEY in HASHTABLE." - (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl))) - (and sym (get sym 'val)))) - -(defun ange-ftp-put-hash-entry (key val tbl) - "Record an association between KEY and VALUE in HASHTABLE." - (let ((sym (intern (ange-ftp-make-hash-key key) tbl))) - (put sym 'val val) - (put sym 'key key))) - -(defun ange-ftp-del-hash-entry (key tbl) - "Copy all symbols except KEY in HASHTABLE and return modified hashtable." - (let* ((len (length tbl)) - (new-tbl (ange-ftp-make-hashtable len)) - (i (1- len))) - (ange-ftp-map-hashtable - (function - (lambda (k v) - (or (equal k key) - (ange-ftp-put-hash-entry k v new-tbl)))) - tbl) - (while (>= i 0) - (aset tbl i (aref new-tbl i)) - (setq i (1- i))) - tbl)) - -(defun ange-ftp-hash-entry-exists-p (key tbl) - "Return whether there is an association for KEY in TABLE." - (intern-soft (ange-ftp-make-hash-key key) tbl)) - -(defun ange-ftp-hash-table-keys (tbl) - "Return a sorted list of all the active keys in the hashtable, as strings." - (sort (all-completions "" tbl) - (function string-lessp))) - -;;;; ------------------------------------------------------------ -;;;; Internal variables. -;;;; ------------------------------------------------------------ - -(defconst ange-ftp-version "Revision: 4.20.XEmacs") - -(defvar ange-ftp-data-buffer-name " *ftp data*" - "Buffer name to hold directory listing data received from ftp process.") - -(defvar ange-ftp-netrc-modtime nil - "Last modified time of the netrc file from file-attributes.") - -(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable) - "Hash table holding associations between HOST, USER pairs.") - -(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable) - "Mapping between a HOST, USER pair and a PASSWORD for them.") - -(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable) - "Mapping between a HOST, USER pair and a ACCOUNT password for them.") - -(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97) - "Hash table for storing directories and their respective files.") - -(defvar ange-ftp-ls-cache-lsargs nil - "Last set of args used by ange-ftp-ls.") - -(defvar ange-ftp-ls-cache-file nil - "Last file passed to ange-ftp-ls.") - -(defvar ange-ftp-ls-cache-res nil - "Last result returned from ange-ftp-ls.") - -;; New error symbols. -;; XEmacs change -(define-error 'ftp-error "FTP error" 'file-error) - -;;; ------------------------------------------------------------ -;;; Match-data support (stolen from Kyle I think) -;;; ------------------------------------------------------------ - -(defmacro ange-ftp-save-match-data (&rest body) - "Execute the BODY forms, restoring the global value of the match data. -Before executing BODY, case-fold-search is locally bound to nil." - (let ((original (make-symbol "match-data")) - case-fold-search) - (list - 'let (list (list original '(match-data))) - (list 'unwind-protect - (cons 'progn body) - (list 'store-match-data original))))) - -(put 'ange-ftp-save-match-data 'lisp-indent-hook 0) -(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form)) - -;;; ------------------------------------------------------------ -;;; Enhanced message support. -;;; ------------------------------------------------------------ - -(defun ange-ftp-message (fmt &rest args) - "Output the given message, but truncate to the size of the minibuffer -window." - (let ((msg (apply (function format) fmt args)) - (max (window-width (minibuffer-window)))) - (if (>= (length msg) max) - (setq msg (concat "> " (substring msg (- 3 max))))) - (message "%s" msg))) - -(defvar ange-ftp-lazy-message-time 0) -(defun ange-ftp-lazy-message (fmt &rest args) - "Output the given message, but truncate to the size of the minibuffer -window, and don't print the message if we've printed another message -less than one second ago." - (if (= ange-ftp-lazy-message-time - (setq ange-ftp-lazy-message-time (nth 1 (current-time)))) - nil - (apply 'ange-ftp-message fmt args))) - -(or (fboundp 'current-time) (fset 'ange-ftp-lazy-message 'ange-ftp-message)) - - -(defun ange-ftp-abbreviate-filename (file &optional new) - "Abbreviate the given filename relative to the default-directory. If the -optional parameter NEW is given and the non-directory parts match, only return -the directory part of the file." - (ange-ftp-save-match-data - (if (and default-directory - (string-match (concat "^" - (regexp-quote default-directory) - ".") file)) - (setq file (substring file (1- (match-end 0))))) - (if (and new - (string-equal (file-name-nondirectory file) - (file-name-nondirectory new))) - (setq file (file-name-directory file))) - (or file "./"))) - -;;;; ------------------------------------------------------------ -;;;; User / Host mapping support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-set-user (host user) - "For a given HOST, set or change the default USER." - (interactive "sHost: \nsUser: ") - (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable)) - -(defun ange-ftp-get-user (host) - "Given a HOST, return the default USER." - (ange-ftp-parse-netrc) - (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable))) - (or user - (prog1 - (setq user - (cond ((stringp ange-ftp-default-user) - ;; We have a default name. Use it. - ange-ftp-default-user) - (ange-ftp-default-user - ;; Ask the user. - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - ;; Default to the user's login name. - (t - (user-login-name)))) - (ange-ftp-set-user host user))))) - -;;;; ------------------------------------------------------------ -;;;; Password support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-read-passwd (prompt &optional default) - "Read a password from the user. -See documentation of `read-passwd' for more info." - (read-passwd prompt nil default)) - -;(defun ange-ftp-read-passwd (prompt &optional default) -; "Read a password from the user. Echos a . for each character typed. -;End with RET, LFD, or ESC. DEL or C-h rubs out. ^U kills line. -;Optional DEFAULT is password to start with." -; (let ((pass (if default default "")) -; (c 0) -; (echo-keystrokes 0) -; (cursor-in-echo-area t)) -; (while (and (/= c ?\r) (/= c ?\n) (/= c ?\e)) -; (message "%s%s" -; prompt -; (make-string (length pass) ?.)) -; (setq c (read-char)) -; (if (= c ?\C-u) -; (setq pass "") -; (if (and (/= c ?\b) (/= c ?\177)) -; (setq pass (concat pass (char-to-string c))) -; (if (> (length pass) 0) -; (setq pass (substring pass 0 -1)))))) -; (ange-ftp-repaint-minibuffer) -; (substring pass 0 -1))) - -(defmacro ange-ftp-generate-passwd-key (host user) - (` (concat (, host) "/" (, user)))) - -(defmacro ange-ftp-lookup-passwd (host user) - (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user)) - ange-ftp-passwd-hashtable))) - -(defun ange-ftp-set-passwd (host user passwd) - "For a given HOST and USER, set or change the associated PASSWORD." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (ange-ftp-read-passwd "Password: "))) - (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) - passwd - ange-ftp-passwd-hashtable)) - -(defun ange-ftp-get-host-with-passwd (user) - "Given a USER, return a host we know the password for." - (ange-ftp-parse-netrc) - (catch 'found-one - (ange-ftp-map-hashtable - (function (lambda (host val) - (if (ange-ftp-lookup-passwd host user) - (throw 'found-one host)))) - ange-ftp-user-hashtable) - (ange-ftp-save-match-data - (ange-ftp-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]*\\(/\\).*$" key) - (let ((host (substring key 0 (match-beginning 1)))) - (if (and (string-equal user (substring key (match-end 1))) - value) - (throw 'found-one host)))))) - ange-ftp-passwd-hashtable)) - nil)) - -(defun ange-ftp-get-passwd (host user) - "Given a HOST and USER, return the FTP password, prompting if it was not -previously set." - (ange-ftp-parse-netrc) - - ;; look up password in the hash table first; user might have overriden the - ;; defaults. - (cond ((ange-ftp-lookup-passwd host user)) - - ;; see if default user and password set from the .netrc file. - ((and (stringp ange-ftp-default-user) - ange-ftp-default-password - (string-equal user ange-ftp-default-user)) - ange-ftp-default-password) - - ;; anonymous ftp password is handled specially since there is an - ;; unwritten rule about how that is used on the Internet. - ((and (or (string-equal user "anonymous") - (string-equal user "ftp")) - ange-ftp-generate-anonymous-password) - (if (stringp ange-ftp-generate-anonymous-password) - ange-ftp-generate-anonymous-password - (concat (user-login-name) "@" (system-name)))) - - ;; see if same user has logged in to other hosts; if so then prompt - ;; with the password that was used there. - (t - (let* ((other (ange-ftp-get-host-with-passwd user)) - (passwd (if other - - ;; found another machine with the same user. - ;; Try that account. - (ange-ftp-read-passwd - (format "passwd for %s@%s (same as %s@%s): " - user host user other) - (ange-ftp-lookup-passwd other user)) - - ;; I give up. Ask the user for the password. - (ange-ftp-read-passwd - (format "Password for %s@%s: " user host))))) - (ange-ftp-set-passwd host user passwd) - passwd)))) - -;;;; ------------------------------------------------------------ -;;;; Account support -;;;; ------------------------------------------------------------ - -;; Account passwords must be either specified in the .netrc file, or set -;; manually by calling ange-ftp-set-account. For the moment, ange-ftp doesn't -;; check to see whether the FTP process is actually prompting for an account -;; password. - -(defun ange-ftp-set-account (host user account) - "For a given HOST and USER, set or change the associated ACCOUNT password." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (ange-ftp-read-passwd "Account password: "))) - (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) - account - ange-ftp-account-hashtable)) - -(defun ange-ftp-get-account (host user) - "Given a HOST and USER, return the FTP account." - (ange-ftp-parse-netrc) - (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user) - ange-ftp-account-hashtable) - (and (stringp ange-ftp-default-user) - (string-equal user ange-ftp-default-user) - ange-ftp-default-account))) - -;;;; ------------------------------------------------------------ -;;;; ~/.netrc support -;;;; ------------------------------------------------------------ - -(defun ange-ftp-chase-symlinks (file) - "Return the filename that FILENAME references, following all symbolic links." - (let (temp) - (while (setq temp (ange-ftp-real-file-symlink-p file)) - (setq file - (if (file-name-absolute-p temp) - temp - (concat (file-name-directory file) temp))))) - file) - -(defun ange-ftp-parse-netrc-token (token limit) - "Move along current line looking for the value of the TOKEN. Valid -separators between TOKEN and its value are commas and whitespace. -Second arg LIMIT is a limit for the search." - (if (search-forward token limit t) - (let (beg) - (skip-chars-forward ", \t\r\n" limit) - (if (eq (following-char) ?\") ;quoted token value - (progn (forward-char 1) - (setq beg (point)) - (skip-chars-forward "^\"" limit) - (forward-char 1) - (buffer-substring beg (1- (point)))) - (setq beg (point)) - (skip-chars-forward "^, \t\r\n" limit) - (buffer-substring beg (point)))))) - -(defun ange-ftp-parse-netrc-group () - "Extract the values for the tokens \`machine\', \`login\', \`password\' -and \`account\' in the current buffer. If successful, record the information -found." - (beginning-of-line) - (let ((start (point)) - (end (progn (re-search-forward "machine\\|default" - (point-max) 'end 2) (point))) - machine login password account) - (goto-char start) - (setq machine (ange-ftp-parse-netrc-token "machine" end) - login (ange-ftp-parse-netrc-token "login" end) - password (ange-ftp-parse-netrc-token "password" end) - account (ange-ftp-parse-netrc-token "account" end)) - (if (and machine login) - ;; found a `machine` token. - (progn - (ange-ftp-set-user machine login) - (ange-ftp-set-passwd machine login password) - (and account - (ange-ftp-set-account machine login account))) - (goto-char start) - (if (search-forward "default" end t) - ;; found a `default' token - (progn - (setq login (ange-ftp-parse-netrc-token "login" end) - password (ange-ftp-parse-netrc-token "password" end) - account (ange-ftp-parse-netrc-token "account" end)) - (and login - (setq ange-ftp-default-user login)) - (and password - (setq ange-ftp-default-password password)) - (and account - (setq ange-ftp-default-account account))))) - (goto-char end))) - -(defun ange-ftp-parse-netrc () - "If ~/.netrc file exists and has the correct permissions then extract the -\`machine\', \`login\', \`password\' and \`account\' information from within." - - ;; We set this before actually doing it to avoid the possibility - ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file. - (interactive) - (let* ((file (ange-ftp-chase-symlinks - (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) - (attr (ange-ftp-real-file-attributes file))) - (if (and attr ; file exists. - (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed - (ange-ftp-save-match-data - (if (or ange-ftp-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr)))) - (save-excursion - ;; we are cheating a bit here. I'm trying to do the equivalent - ;; of find-file on the .netrc file, but then nuke it afterwards. - ;; with the bit of logic below we should be able to have - ;; encrypted .netrc files. - (set-buffer (generate-new-buffer "*ftp-.netrc*")) - (ange-ftp-real-insert-file-contents file) - (setq buffer-file-name file) - (setq default-directory (file-name-directory file)) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (goto-char (point-min)) - (while (not (eobp)) - (ange-ftp-parse-netrc-group)) - (kill-buffer (current-buffer))) - (ange-ftp-message "%s either not owned by you or badly protected." - ange-ftp-netrc-filename) - (sit-for 1)) - (setq ange-ftp-netrc-modtime (nth 5 attr)))))) - -(defun ange-ftp-generate-root-prefixes () - "Return a list of prefixes of the form 'user@host:' to be used when -completion is done in the root directory." - (ange-ftp-parse-netrc) - (ange-ftp-save-match-data - (let (res) - (ange-ftp-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]*\\(/\\).*$" key) - (let ((host (substring key 0 (match-beginning 1))) - (user (substring key (match-end 1)))) - (setq res (cons (list (concat user "@" host ":")) - res)))))) - ange-ftp-passwd-hashtable) - (ange-ftp-map-hashtable - (function (lambda (host user) - (setq res (cons (list (concat host ":")) - res)))) - ange-ftp-user-hashtable) -;; (or res (list nil)) - res - ))) - -;;;; ------------------------------------------------------------ -;;;; Remote pathname syntax support. -;;;; ------------------------------------------------------------ - -(defmacro ange-ftp-ftp-path-component (n ns path) - "Extract the Nth ftp path component from NS." - (` (let ((elt (nth (, n) (, ns)))) - (if (match-beginning elt) - (substring (, path) (match-beginning elt) (match-end elt)))))) - -(defvar ange-ftp-ftp-path-arg "") -(defvar ange-ftp-ftp-path-res nil) - -(defun ange-ftp-ftp-path (path) - "Parse PATH according to ange-ftp-path-format (which see). -Returns a list (HOST USER PATH), or nil if PATH does not match the format." - (if (string-equal path ange-ftp-ftp-path-arg) - ange-ftp-ftp-path-res - (setq ange-ftp-ftp-path-arg path - ange-ftp-ftp-path-res - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-path-format) path) - (let* ((ns (cdr ange-ftp-path-format)) - (host (ange-ftp-ftp-path-component 0 ns path)) - (user (ange-ftp-ftp-path-component 1 ns path)) - (path (ange-ftp-ftp-path-component 2 ns path))) - (if (zerop (length user)) - (setq user (ange-ftp-get-user host))) - (list host user path)) - nil))))) - -(defun ange-ftp-replace-path-component (fullpath path) - "Take a FULLPATH that matches according to ange-ftp-path-format and -replace the path component with PATH." - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-path-format) fullpath) - (let* ((ns (cdr ange-ftp-path-format)) - (elt (nth 2 ns))) - (concat (substring fullpath 0 (match-beginning elt)) - path - (substring fullpath (match-end elt))))))) - -;;;; ------------------------------------------------------------ -;;;; Miscellaneous utils. -;;;; ------------------------------------------------------------ - -(setq ange-ftp-tmp-keymap (make-sparse-keymap)) -(define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer) - -(defun ange-ftp-repaint-minibuffer () - "Gross hack to set minibuf_message = 0, so that the contents of the -minibuffer will show." - (if (eq (selected-window) (minibuffer-window)) - (if (string-match "XEmacs" emacs-version) - (message nil) - ;; v18 GNU Emacs - (let ((unread-command-char ?\C-m) - (enable-recursive-minibuffers t)) - (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil))))) - -(defun ange-ftp-ftp-process-buffer (host user) - "Return the name of the buffer that collects output from the ftp process -connected to the given HOST and USER pair." - (concat "*ftp " user "@" host "*")) - -(defun ange-ftp-error (host user msg) - "Display the last chunk of output from the ftp process for the given HOST -USER pair, and signal an error including MSG in the text." - (let ((cur (selected-window)) - (pop-up-windows t)) - (pop-to-buffer - (get-buffer-create - (ange-ftp-ftp-process-buffer host user))) - (goto-char (point-max)) - (select-window cur)) - (signal 'ftp-error (list (format "FTP Error: %s" msg)))) - -(defun ange-ftp-set-buffer-mode () - "Set the correct modes for the current buffer if it is visiting a remote -file." - (if (and (stringp buffer-file-name) - (ange-ftp-ftp-path buffer-file-name)) - (progn - (auto-save-mode ange-ftp-auto-save) - (make-variable-buffer-local 'revert-buffer-function) - (setq revert-buffer-function 'ange-ftp-revert-buffer)))) - -(defun ange-ftp-kill-ftp-process (buffer) - "If the BUFFER's visited filename or default-directory is an ftp filename -then kill the related ftp process." - (interactive "bKill FTP process associated with buffer: ") - (if (null buffer) - (setq buffer (current-buffer))) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (ange-ftp-ftp-path (expand-file-name file)))) - (if parsed - (let ((host (nth 0 parsed)) - (user (nth 1 parsed))) - (kill-buffer (ange-ftp-ftp-process-buffer host user)))))))) - -(defun ange-ftp-quote-string (string) - "Quote any characters in STRING that may confuse the ftp process." - (apply (function concat) - (mapcar (function - (lambda (char) - (if (or (<= char ? ) - (> char ?\~) - (= char ?\") - (= char ?\\)) - (vector ?\\ char) - (vector char)))) - string))) - -(defun ange-ftp-barf-if-not-directory (directory) - (or (file-directory-p directory) - (signal 'file-error - (list "Opening directory" - (if (file-exists-p directory) - "not a directory" - "no such file or directory") - directory)))) - -;;;; ------------------------------------------------------------ -;;;; FTP process filter support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-process-handle-line (line proc) - "Look at the given LINE from the ftp process PROC. Try to catagorize it -into one of four categories: good, skip, fatal, or unknown." - (cond ((string-match ange-ftp-xfer-size-msgs line) - (setq ange-ftp-xfer-size - (ash (string-to-int (substring line - (match-beginning 1) - (match-end 1))) - -10))) - ((string-match ange-ftp-skip-msgs line) - (setq ange-ftp-process-multi-skip nil) ;; XEmacs patch (Bob Weiner) - t) - ((string-match ange-ftp-good-msgs line) - (setq ange-ftp-process-busy nil - ange-ftp-process-result t - ange-ftp-process-result-line line)) - ((string-match ange-ftp-fatal-msgs line) - (delete-process proc) - (setq ange-ftp-process-busy nil - ange-ftp-process-result-line line)) - ((string-match ange-ftp-multi-msgs line) - (setq ange-ftp-process-multi-skip t)) - (ange-ftp-process-multi-skip - t) - (t - (setq ange-ftp-process-busy nil - ange-ftp-process-result-line line)))) - -(defun ange-ftp-process-log-string (proc str) - "For a given PROCESS, log the given STRING at the end of its -associated buffer." - (let ((old-buffer (current-buffer))) - (unwind-protect - (let (moving) - (set-buffer (process-buffer proc)) - (setq moving (= (point) (process-mark proc))) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert str) - (set-marker (process-mark proc) (point))) - (if moving (goto-char (process-mark proc)))) - (set-buffer old-buffer)))) - -(defun ange-ftp-set-xfer-size (host user bytes) - "Set the size of the next FTP transfer in bytes." - (let ((proc (ange-ftp-get-process host user))) - (if proc - (let ((buf (process-buffer proc))) - (if buf - (save-excursion - (set-buffer buf) - (setq ange-ftp-xfer-size (ash bytes -10)))))))) - -(defun ange-ftp-process-handle-hash (str) - "Remove hash marks from STRING and display count so far." - (setq str (concat (substring str 0 (match-beginning 0)) - (substring str (match-end 0))) - ange-ftp-hash-mark-count (+ (- (match-end 0) - (match-beginning 0)) - ange-ftp-hash-mark-count)) - (and ange-ftp-process-msg - ange-ftp-process-verbose - (not (eq (selected-window) (minibuffer-window))) - (not (boundp 'search-message)) ;screws up isearch otherwise - (not cursor-in-echo-area) ;screws up y-or-n-p otherwise - (let ((kbytes (ash (* ange-ftp-hash-mark-unit - ange-ftp-hash-mark-count) - -6))) - (if (zerop ange-ftp-xfer-size) - (ange-ftp-lazy-message "%s...%dk" ange-ftp-process-msg kbytes) - (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size))) - ;; cut out the redisplay of identical %-age messages. - (if (not (eq percent ange-ftp-last-percent)) - (progn - (setq ange-ftp-last-percent percent) - (ange-ftp-lazy-message "%s...%d%%" - ange-ftp-process-msg percent))))))) - str) - -(defun ange-ftp-call-cont (cont result line) - "Call the function specified by CONT. CONT can be either a function or a -list of a function and some args. The first two parameters passed to the -function will be RESULT and LINE. The remaining args will be taken from CONT -if a list was passed." - (if cont - (if (and (listp cont) - (not (eq (car cont) 'lambda))) - (apply (car cont) result line (cdr cont)) - (funcall cont result line)))) - -(defun ange-ftp-process-filter (proc str) - "Build up a complete line of output from the ftp PROCESS and pass it -on to ange-ftp-process-handle-line to deal with." - (let ((buffer (process-buffer proc)) - (old-buffer (current-buffer))) - - ;; see if the buffer is still around... it could have been deleted. - (if (buffer-name buffer) - (unwind-protect - (ange-ftp-save-match-data - (set-buffer (process-buffer proc)) - - ;; handle hash mark printing - (and ange-ftp-hash-mark-unit - ange-ftp-process-busy - (string-match "^#+$" str) - (setq str (ange-ftp-process-handle-hash str))) - (ange-ftp-process-log-string proc str) - (if ange-ftp-process-busy - (progn - (setq ange-ftp-process-string (concat ange-ftp-process-string - str)) - - ;; if we gave an empty password to the USER command earlier - ;; then we should send a null password now. - (if (string-match "Password: *$" ange-ftp-process-string) - (send-string proc "\n")))) - (while (and ange-ftp-process-busy - (string-match "\n" ange-ftp-process-string)) - (let ((line (substring ange-ftp-process-string - 0 - (match-beginning 0)))) - (setq ange-ftp-process-string (substring ange-ftp-process-string - (match-end 0))) - (while (string-match "^ftp> *" line) - (setq line (substring line (match-end 0)))) - (ange-ftp-process-handle-line line proc))) - - ;; has the ftp client finished? if so then do some clean-up - ;; actions. - (if (not ange-ftp-process-busy) - (progn - ;; reset the xfer size - (setq ange-ftp-xfer-size 0) - - ;; issue the "done" message since we've finished. - (if (and ange-ftp-process-msg - ange-ftp-process-verbose - ange-ftp-process-result) - (progn - (ange-ftp-message "%s...done" ange-ftp-process-msg) - (ange-ftp-repaint-minibuffer) - (setq ange-ftp-process-msg nil))) - - ;; is there a continuation we should be calling? if so, - ;; we'd better call it, making sure we only call it once. - (if ange-ftp-process-continue - (let ((cont ange-ftp-process-continue)) - (setq ange-ftp-process-continue nil) - (ange-ftp-call-cont cont - ange-ftp-process-result - ange-ftp-process-result-line)))))) - (set-buffer old-buffer))))) - -(defun ange-ftp-process-sentinel (proc str) - "When ftp process changes state, nuke all file-entries in cache." - (ange-ftp-save-match-data - (let ((name (process-name proc))) - (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name) - (let ((user (substring name (match-beginning 1) (match-end 1))) - (host (substring name (match-beginning 2) (match-end 2)))) - (ange-ftp-wipe-file-entries host user)))) - (setq ange-ftp-ls-cache-file nil))) - -;;;; ------------------------------------------------------------ -;;;; Gateway support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-use-gateway-p (host) - "Returns whether to access this host via a normal (non-smart) gateway." - ;; yes, I know that I could simplify the following expression, but it is - ;; clearer (to me at least) this way. - (and (not ange-ftp-smart-gateway) - (ange-ftp-save-match-data - (not (string-match ange-ftp-local-host-regexp host))))) - -(defun ange-ftp-use-smart-gateway-p (host) - "Returns whether to access this host via a smart gateway." - (and ange-ftp-smart-gateway - (ange-ftp-save-match-data - (not (string-match ange-ftp-local-host-regexp host))))) - - -;;; ------------------------------------------------------------ -;;; Temporary file location and deletion... -;;; ------------------------------------------------------------ - -(defvar ange-ftp-tmp-name-files ()) -(defvar ange-ftp-tmp-name-hashtable (ange-ftp-make-hashtable 10)) -(defvar ange-ftp-pid nil) - -(defun ange-ftp-get-pid () - "Half-hearted attempt to get the current process's id." - (setq ange-ftp-pid (substring (make-temp-name "") 1))) - -(defun ange-ftp-make-tmp-name (host) - "This routine will return the name of a new file." - (let* ((template (if (ange-ftp-use-gateway-p host) - ange-ftp-gateway-tmp-name-template - ange-ftp-tmp-name-template)) - (pid (or ange-ftp-pid (ange-ftp-get-pid))) - (start ?a) - file entry) - (while - (progn - (setq file (format "%s%c%s" template start pid)) - (setq entry (intern file ange-ftp-tmp-name-hashtable)) - (or (memq entry ange-ftp-tmp-name-files) - (ange-ftp-real-file-exists-p file))) - (if (> (setq start (1+ start)) ?z) - (progn - (setq template (concat template "X")) - (setq start ?a)))) - (setq ange-ftp-tmp-name-files - (cons entry ange-ftp-tmp-name-files)) - file)) - -(defun ange-ftp-del-tmp-name (temp) - (setq ange-ftp-tmp-name-files - (delq (intern temp ange-ftp-tmp-name-hashtable) - ange-ftp-tmp-name-files)) - (condition-case () - (ange-ftp-real-delete-file temp) - (error nil))) - -;;;; ------------------------------------------------------------ -;;;; Interactive gateway program support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-gwp-running t) -(defvar ange-ftp-gwp-status nil) - -(defun ange-ftp-gwp-sentinel (proc str) - (setq ange-ftp-gwp-running nil)) - -(defun ange-ftp-gwp-filter (proc str) - (ange-ftp-save-match-data - (ange-ftp-process-log-string proc str) - (cond ((string-match "login: *$" str) - (send-string proc - (concat - (let ((ange-ftp-default-user t)) - (ange-ftp-get-user ange-ftp-gateway-host)) - "\n"))) - ((string-match "Password: *$" str) - (send-string proc - (concat - (ange-ftp-get-passwd ange-ftp-gateway-host - (ange-ftp-get-user - ange-ftp-gateway-host)) - "\n"))) - ((string-match ange-ftp-gateway-fatal-msgs str) - (delete-process proc) - (setq ange-ftp-gwp-running nil)) - ((string-match ange-ftp-gateway-prompt-pattern str) - (setq ange-ftp-gwp-running nil - ange-ftp-gwp-status t))))) - -(defun ange-ftp-gwp-start (host user name args) - "Login to the gateway machine and fire up an ftp process." - (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host)) - (proc (start-process name name - ange-ftp-gateway-program - ange-ftp-gateway-host)) - (ftp (mapconcat (function identity) args " "))) - (process-kill-without-query proc) - (set-process-sentinel proc (function ange-ftp-gwp-sentinel)) - (set-process-filter proc (function ange-ftp-gwp-filter)) - (set-marker (process-mark proc) (point)) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host) - (while ange-ftp-gwp-running ;perform login sequence - (accept-process-output proc)) - (if (not ange-ftp-gwp-status) - (ange-ftp-error host user "unable to login to gateway")) - (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (process-send-string proc ange-ftp-gateway-setup-term-command) - (while ange-ftp-gwp-running ;zap ^M's and double echoing. - (accept-process-output proc)) - (if (not ange-ftp-gwp-status) - (ange-ftp-error host user "unable to set terminal modes on gateway")) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process - proc)) - -;;;; ------------------------------------------------------------ -;;;; Support for sending commands to the ftp process. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait) - "Low-level routine to send the given ftp CMD to the ftp PROCESS. -MSG is an optional message to output before and after the command. -If CONT is non-NIL then it is either a function or a list of function and -some arguments. The function will be called when the ftp command has completed. -If CONT is NIL then this routine will return \( RESULT . LINE \) where RESULT -is whether the command was successful, and LINE is the line from the FTP -process that caused the command to complete. -If NOWAIT is given then the routine will return immediately the command has -been queued with no result. CONT will still be called, however." - (if (memq (process-status proc) '(run open)) - (save-excursion - (set-buffer (process-buffer proc)) - (while ange-ftp-process-busy - (accept-process-output)) - (setq ange-ftp-process-string "" - ange-ftp-process-result-line "" - ange-ftp-process-busy t - ange-ftp-process-result nil - ange-ftp-process-multi-skip nil - ange-ftp-process-msg msg - ange-ftp-process-continue cont - ange-ftp-hash-mark-count 0 - ange-ftp-last-percent -1 - cmd (concat cmd "\n")) - (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg)) - (goto-char (point-max)) -; (move-marker last-input-start (point)) - ;; don't insert the password into the buffer on the USER command. - (ange-ftp-save-match-data - (if (string-match "^user \"[^\"]*\"" cmd) - (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") - (insert cmd))) -; (move-marker last-input-end (point)) - (send-string proc cmd) - (set-marker (process-mark proc) (point)) - (if nowait - nil - ;; hang around for command to complete - (while ange-ftp-process-busy - (accept-process-output proc)) - (if cont - nil ;cont has already been called - (cons ange-ftp-process-result ange-ftp-process-result-line)))))) - -(defun ange-ftp-nslookup-host (host) - "Attempt to resolve the given HOSTNAME using nslookup if possible." - (interactive "sHost: ") - (if ange-ftp-nslookup-program - (let ((proc (start-process " *nslookup*" " *nslookup*" - ange-ftp-nslookup-program host)) - (res host)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc)) - (goto-char (point-min)) - (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) - (setq res (buffer-substring (match-beginning 1) - (match-end 1)))) - (kill-buffer (current-buffer))) - res) - host)) - -(defun ange-ftp-start-process (host user name) - "Spawn a new ftp process ready to connect to machine HOST and give it NAME. -If HOST is only ftp-able through a gateway machine then spawn a shell -on the gateway machine to do the ftp instead." - (let* ((use-gateway (ange-ftp-use-gateway-p host)) - (ftp-prog (if use-gateway - ange-ftp-gateway-ftp-program-name - ange-ftp-ftp-program-name)) - (args (append (list ftp-prog) ange-ftp-ftp-program-args)) - (saved-term-var (getenv "TERM")) - proc) - ;; fix problems in losing Linux FTP's, which like to output - ;; ESC sequences to highlight the ftp prompt, which messes things up - (unwind-protect - (progn - (setenv "TERM" "dumb") - (if use-gateway - (if ange-ftp-gateway-program-interactive - (setq proc (ange-ftp-gwp-start host user name args)) - (setq proc (apply 'start-process name name - (append (list ange-ftp-gateway-program - ange-ftp-gateway-host) - args)))) - (setq proc (apply 'start-process name name args))) - (process-kill-without-query proc) - (set-process-sentinel proc (function ange-ftp-process-sentinel)) - (set-process-filter proc (function ange-ftp-process-filter))) - (setenv "TERM" saved-term-var)) - ;; jwz: turn on shell mode after setting the proc filter for the - ;; benefit of shell-font. - (require 'shell) - (save-excursion - (set-buffer (process-buffer proc)) - (ange-ftp-shell-mode)) - (accept-process-output proc) ;wait for ftp startup message - proc)) - -(defun ange-ftp-smart-login (host user pass account proc) - "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. -PROC is the FTP-client's process. This routine uses the smart-gateway -host specified in ``ange-ftp-gateway-host''." - (let ((result (ange-ftp-raw-send-cmd - proc - (format "open %s %s" - (ange-ftp-nslookup-host ange-ftp-gateway-host) - ange-ftp-smart-gateway-port) - (format "Opening FTP connection to %s via %s" - host - ange-ftp-gateway-host)))) - (or (car result) - (ange-ftp-error host user - (concat "OPEN request failed: " - (cdr result)))) - (setq result (ange-ftp-raw-send-cmd - proc (format "user \"%s\"@%s %s %s" - user - (ange-ftp-nslookup-host host) - pass - account) - (format "Logging in as user %s@%s" - user host))) - (or (car result) - (progn - (ange-ftp-set-passwd host user nil) ; reset password - (ange-ftp-set-account host user nil) ; reset account - (ange-ftp-error host user - (concat "USER request failed: " - (cdr result))))))) - -(defun ange-ftp-normal-login (host user pass account proc) - "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. -PROC is the process to the FTP-client." - (let ((result (ange-ftp-raw-send-cmd - proc - (format "open %s" (ange-ftp-nslookup-host host)) - (format "Opening FTP connection to %s" host)))) - (or (car result) - (ange-ftp-error host user - (concat "OPEN request failed: " - (cdr result)))) - (setq result (ange-ftp-raw-send-cmd - proc - (format "user \"%s\" %s %s" user pass account) - (format "Logging in as user %s@%s" user host))) - (or (car result) - (progn - (ange-ftp-set-passwd host user nil) ;reset password. - (ange-ftp-set-account host user nil) ;reset account. - (ange-ftp-error host user - (concat "USER request failed: " - (cdr result))))))) - -(defvar ange-ftp-hash-mark-msgs - "[hH]ash mark [^0-9]*\\([0-9]+\\)" - "*Regexp matching the FTP client's output upon doing a HASH command.") - -(defun ange-ftp-guess-hash-mark-size (proc) - (if ange-ftp-send-hash - (save-excursion - (set-buffer (process-buffer proc)) - (let* ((status (ange-ftp-raw-send-cmd proc "hash")) - (result (car status)) - (line (cdr status))) - (ange-ftp-save-match-data - (if (string-match ange-ftp-hash-mark-msgs line) - (let ((size (string-to-int - (substring line - (match-beginning 1) - (match-end 1))))) - (setq ange-ftp-ascii-hash-mark-size size - ange-ftp-hash-mark-unit (ash size -4)) - - ;; if a default value for this is set, use that value. - (or ange-ftp-binary-hash-mark-size - (setq ange-ftp-binary-hash-mark-size size))))))))) - -(defun ange-ftp-get-process (host user) - "Return the process object for a FTP process connected to HOST and -logged in as USER. Create a new process if needed." - (let* ((name (ange-ftp-ftp-process-buffer host user)) - (proc (get-process name))) - (if (and proc (memq (process-status proc) '(run open))) - proc - (let ((pass (ange-ftp-quote-string - (ange-ftp-get-passwd host user))) - (account (ange-ftp-quote-string - (ange-ftp-get-account host user)))) - ;; grab a suitable process. - (setq proc (ange-ftp-start-process host user name)) - - ;; login to FTP server. - (if (ange-ftp-use-smart-gateway-p host) - (ange-ftp-smart-login host user pass account proc) - (ange-ftp-normal-login host user pass account proc)) - - ;; Tell client to send back hash-marks as progress. It isn't usually - ;; fatal if this command fails. - (ange-ftp-guess-hash-mark-size proc) - - ;; Guess at the host type. - (ange-ftp-guess-host-type host user) - - ;; Run any user-specified hooks. Note that proc, host and user are - ;; dynamically bound at this point. - (run-hooks 'ange-ftp-process-startup-hook)) - proc))) - -;; Variables for caching host and host-type -(defvar ange-ftp-host-cache nil) -(defvar ange-ftp-host-type-cache nil) - -;; If ange-ftp-host-type is called with the optional user -;; argument, it will attempt to guess the host type by connecting -;; as user, if necessary. For efficiency, I have tried to give this -;; optional second argument only when necessary. Have I missed any calls -;; to ange-ftp-host-type where it should have been supplied? - -(defun ange-ftp-host-type (host &optional user) - "Return a symbol which represents the type of the HOST given. -If the optional argument USER is given, attempts to guess the -host-type by logging in as USER." - (if (eq host ange-ftp-host-cache) - ange-ftp-host-type-cache - ;; Trigger an ftp connection, in case we need to guess at the host type. - (if (and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache)) - ange-ftp-host-type-cache - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache - (cond ((ange-ftp-dumb-unix-host host) - 'dumb-unix) - ((and (fboundp 'ange-ftp-vos-host) - (ange-ftp-vos-host host)) - 'vos) - ((and (fboundp 'ange-ftp-vms-host) - (ange-ftp-vms-host host)) - 'vms) - ((and (fboundp 'ange-ftp-mts-host) - (ange-ftp-mts-host host)) - 'mts) - ((and (fboundp 'ange-ftp-cms-host) - (ange-ftp-cms-host host)) - 'cms) - (t - 'unix)))))) - -;; It would be nice to abstract the functions ange-ftp-TYPE-host and -;; ange-ftp-add-TYPE-host. The trick is to abstract these functions -;; without sacrificing speed. Also, having separate variables -;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to -;; set an alist to indicate that a host is of a given type. Even with -;; automatic host type recognition, setting a regexp is still a good idea -;; (for efficiency) if you log into a particular non-UNIX host frequently. - -(defvar ange-ftp-fix-path-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine -which can change a UNIX path into a path more suitable for a host of type -TYPE.") - -(defvar ange-ftp-fix-dir-path-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine -which can change UNIX directory path into a directory path more suitable -for a host of type TYPE.") - -;; *** Perhaps the sense of this variable should be inverted, since there -;; *** is only 1 host type that can take ls-style listing options. -(defvar ange-ftp-dumb-host-types '(dumb-unix) - "List of host types that can't take UNIX ls-style listing options.") - -(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait) - "Find an ftp process connected to HOST logged in as USER and send it CMD. -MSG is an optional status message to be output before and after issuing the -command. -See the documentation for ange-ftp-raw-send-cmd for a description of CONT -and NOWAIT." - ;; Handle conversion to remote pathname syntax and remote ls option - ;; capability. - (let ((cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - cmd2 cmd3 host-type fix-pathname-func) - - (cond - - ;; pwd case (We don't care what host-type.) - ((null cmd1)) - - ;; cmd == 'dir "remote-path" "local-path" "ls-switches" - ((progn - (setq cmd2 (nth 2 cmd) - host-type (ange-ftp-host-type host user)) - ;; This will trigger an FTP login, if one doesn't exist - (eq cmd0 'dir)) - (setq cmd1 (funcall - (or (cdr (assq host-type ange-ftp-fix-dir-path-func-alist)) - 'identity) - cmd1) - cmd3 (nth 3 cmd)) - ;; Need to deal with the HP-UX ftp bug. This should also allow - ;; us to resolve symlinks to directories on SysV machines. (Sebastian will - ;; be happy.) - (and (eq host-type 'unix) - (string-match "/$" cmd1) - (not (string-match "R" cmd3)) - (setq cmd1 (concat cmd1 "."))) - ;; If the remote ls can take switches, put them in - (or (memq host-type ange-ftp-dumb-host-types) - (setq cmd0 'ls - cmd1 (format "\"%s %s\"" cmd3 cmd1)))) - - ;; First argument is the remote pathname - ((progn - (setq fix-pathname-func (or (cdr (assq host-type - ange-ftp-fix-path-func-alist)) - 'identity)) - (memq cmd0 '(get delete mkdir rmdir cd))) - (setq cmd1 (funcall fix-pathname-func cmd1))) - - ;; Second argument is the remote pathname - ((memq cmd0 '(append put chmod)) - (setq cmd2 (funcall fix-pathname-func cmd2))) - - ;; Both arguments are remote pathnames - ((eq cmd0 'rename) - (setq cmd1 (funcall fix-pathname-func cmd1) - cmd2 (funcall fix-pathname-func cmd2)))) - - ;; Turn the command into one long string - (setq cmd0 (symbol-name cmd0)) - (setq cmd (concat cmd0 - (and cmd1 (concat " " cmd1)) - (and cmd2 (concat " " cmd2)))) - - ;; Actually send the resulting command. - (let (afsc-result - afsc-line) - (ange-ftp-raw-send-cmd - (ange-ftp-get-process host user) - cmd - msg - (list - (function (lambda (result line host user - cmd msg cont nowait) - (or cont - (setq afsc-result result - afsc-line line)) - (if result - (ange-ftp-call-cont cont result line) - (ange-ftp-raw-send-cmd - (ange-ftp-get-process host user) - cmd - msg - (list - (function (lambda (result line cont) - (or cont - (setq afsc-result result - afsc-line line)) - (ange-ftp-call-cont cont result line))) - cont) - nowait)))) - host user cmd msg cont nowait) - nowait) - - (if nowait - nil - (if cont - nil - (cons afsc-result afsc-line)))))) - -;; It might be nice to message users about the host type identified, -;; but there is so much other messaging going on, it would not be -;; seen. No point in slowing things down just so users can read -;; a host type message. - -(defconst ange-ftp-cms-path-template - (concat - "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" - "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$")) -(defconst ange-ftp-vms-path-template - "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") -(defconst ange-ftp-mts-path-template - "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") - -(defun ange-ftp-guess-host-type (host user) - "Guess at the host type of HOST by doing a pwd, and examining -the directory syntax." - (let ((host-type (ange-ftp-host-type host)) - (key (concat host "/" user "/~"))) - (if (eq host-type 'unix) - ;; Note that ange-ftp-host-type returns unix as the default value. - (ange-ftp-save-match-data - (let* ((result (ange-ftp-get-pwd host user)) - (dir (car result)) - fix-path-func) - (cond ((null dir) - (message "Warning! Unable to get home directory") - (sit-for 1) - (if (string-match - "^450 No current working directory defined$" - (cdr result)) - - ;; We'll assume that if pwd bombs with this - ;; error message, then it's CMS. - (progn - (ange-ftp-add-cms-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'cms)))) - - ;; try for VMS - ((string-match ange-ftp-vms-path-template dir) - (ange-ftp-add-vms-host host) - ;; The add-host functions clear the host type cache. - ;; Therefore, need to set the cache afterwards. - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'vms)) - - ;; try for MTS - ((string-match ange-ftp-mts-path-template dir) - (ange-ftp-add-mts-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'mts)) - - ;; try for CMS - ((string-match ange-ftp-cms-path-template dir) - (ange-ftp-add-cms-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'cms)) - - ;; assume UN*X - (t - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'unix))) - - ;; Now that we have done a pwd, might as well put it in - ;; the expand-dir hashtable. - (setq fix-path-func (cdr (assq ange-ftp-host-type-cache - ange-ftp-fix-path-func-alist))) - (if fix-path-func - (setq dir (funcall fix-path-func dir 'reverse))) - (ange-ftp-put-hash-entry key dir - ange-ftp-expand-dir-hashtable)))) - - ;; In the special case of CMS make sure that know the - ;; expansion of the home minidisk now, because we will - ;; be doing a lot of cd's. - (if (and (eq host-type 'cms) - (not (ange-ftp-hash-entry-exists-p - key ange-ftp-expand-dir-hashtable))) - (let ((dir (car (ange-ftp-get-pwd host user)))) - (if dir - (ange-ftp-put-hash-entry key (concat "/" dir) - ange-ftp-expand-dir-hashtable) - (message "Warning! Unable to get home directory") - (sit-for 1)))))) - - -;;;; ------------------------------------------------------------ -;;;; Simple FTP process shell support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-shell-mode-map nil) - -(defun ange-ftp-shell-mode () - "Major mode for interacting with an FTP process. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. - -The following commands imitate the usual Unix interrupt and editing -control characters: -\\{ange-ftp-shell-mode-map} -Runs ange-ftp-shell-mode-hook if not nil." - (interactive) - (let ((proc (get-buffer-process (current-buffer)))) - (kill-all-local-variables) - (shell-mode) - (if (null ange-ftp-shell-mode-map) - (progn - (setq ange-ftp-shell-mode-map (make-sparse-keymap)) - (set-keymap-parent ange-ftp-shell-mode-map shell-mode-map) - (set-keymap-name ange-ftp-shell-mode-map 'ange-ftp-shell-mode-map))) - (use-local-map ange-ftp-shell-mode-map) - (setq major-mode 'ange-ftp-shell-mode) - (setq mode-name "ange-ftp") - (goto-char (point-max)) - (set-marker (process-mark proc) (point)) - (set (make-local-variable 'ange-ftp-process-string) nil) - (setq ange-ftp-process-string "") - (set (make-local-variable 'ange-ftp-process-busy) nil) - (set (make-local-variable 'ange-ftp-process-result) nil) - (set (make-local-variable 'ange-ftp-process-msg) nil) - (set (make-local-variable 'ange-ftp-process-multi-skip) nil) - (set (make-local-variable 'ange-ftp-process-result-line) nil) - (set (make-local-variable 'ange-ftp-process-continue) nil) - (set (make-local-variable 'ange-ftp-hash-mark-count) nil) - (set (make-local-variable 'ange-ftp-binary-hash-mark-size) nil) - (set (make-local-variable 'ange-ftp-ascii-hash-mark-size) nil) - (set (make-local-variable 'ange-ftp-hash-mark-unit) nil) - (set (make-local-variable 'ange-ftp-xfer-size) nil) - (set (make-local-variable 'ange-ftp-last-percent) nil) - (setq ange-ftp-hash-mark-count 0) - (setq ange-ftp-xfer-size 0) - (setq ange-ftp-process-result-line "") - (run-hooks 'ange-ftp-shell-mode-hook))) - -;;;; ------------------------------------------------------------ -;;;; Remote file and directory listing support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-dumb-unix-host (host) - "Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands -to take switch arguments." - (and ange-ftp-dumb-unix-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-dumb-unix-host-regexp host)))) - -(defun ange-ftp-add-dumb-unix-host (host) - "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-dumb-unix-host host)) - (setq ange-ftp-dumb-unix-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-dumb-unix-host-regexp "\\|") - ange-ftp-dumb-unix-host-regexp) - ange-ftp-host-cache nil))) - -(defvar ange-ftp-parse-list-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine -which can parse the output from a DIR listing for a host of type TYPE.") - -;; With no-error nil, this function returns: -;; an error if file is not an ange-ftp-path -;; (This should never happen.) -;; an error if either the listing is unreadable or there is an ftp error. -;; the listing (a string), if everything works. -;; -;; With no-error t, it returns: -;; an error if not an ange-ftp-path -;; error if listing is unreable (most likely caused by a slow connection) -;; nil if ftp error (this is because although asking to list a nonexistent -;; directory on a remote unix machine usually (except -;; maybe for dumb hosts) returns an ls error, but no -;; ftp error, if the same is done on a VMS machine, -;; an ftp error is returned. Need to trap the error -;; so we can go on and try to list the parent.) -;; the listing, if everything works. - -(defun ange-ftp-ls (file lsargs parse &optional no-error) - "Return the output of an `DIR' or `ls' command done over ftp. -FILE is the full name of the remote file, LSARGS is any args to pass to the -`ls' command, and PARSE specifies that the output should be parsed and stored -away in the internal cache." - ;; If parse is t, we assume that file is a directory. i.e. we only parse - ;; full directory listings. - (setq file (ange-ftp-expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (key (directory-file-name file)) - (host-type (ange-ftp-host-type host user)) - (dumb (memq host-type ange-ftp-dumb-host-types)) - result - temp - lscmd parse-func) - (if (string-equal path "") - (setq path - (ange-ftp-real-file-name-as-directory - (ange-ftp-expand-dir host user "~")))) - (if (and ange-ftp-ls-cache-file - (string-equal key ange-ftp-ls-cache-file) - ;; Don't care about lsargs for dumb hosts. - (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs))) - ange-ftp-ls-cache-res - (setq temp (ange-ftp-make-tmp-name host)) - (setq lscmd (list 'dir path temp lsargs)) - (unwind-protect - (if (car (setq result (ange-ftp-send-cmd - host - user - lscmd - (format "Listing %s" - (ange-ftp-abbreviate-filename - file))))) - (save-excursion - (set-buffer (get-buffer-create - ange-ftp-data-buffer-name)) - (erase-buffer) - (if (ange-ftp-real-file-readable-p temp) - (ange-ftp-real-insert-file-contents temp) - (sleep-for ange-ftp-retry-time) - ;wait for file to possibly appear - (if (ange-ftp-real-file-readable-p temp) - ;; Try again. - (ange-ftp-real-insert-file-contents temp) - (ange-ftp-error host user - (format - "list data file %s not readable" - temp)))) - (if parse - (ange-ftp-set-files - file - (if (setq - parse-func - (cdr (assq host-type - ange-ftp-parse-list-func-alist))) - (funcall parse-func) - (ange-ftp-parse-dired-listing lsargs)))) - (setq ange-ftp-ls-cache-file key - ange-ftp-ls-cache-lsargs lsargs - ; For dumb hosts-types this is - ; meaningless but harmless. - ange-ftp-ls-cache-res (buffer-string)) - ;; (kill-buffer (current-buffer)) - ange-ftp-ls-cache-res) - (if no-error - nil - (ange-ftp-error host user - (concat "DIR failed: " (cdr result))))) - (ange-ftp-del-tmp-name temp)))) - (error "Should never happen. Please report. Bug ref. no.: 1")))) - -;;;; ------------------------------------------------------------ -;;;; Directory information caching support. -;;;; ------------------------------------------------------------ - -(defconst ange-ftp-date-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) +[0-3]?[0-9] ")) - -(defvar ange-ftp-add-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC -is a function to be used to add a file entry for the OS TYPE. The -main reason for this alist is to deal with file versions in VMS.") - -(defvar ange-ftp-delete-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC -is a function to be used to delete a file entry for the OS TYPE. -The main reason for this alist is to deal with file versions in -VMS.") - -(defun ange-ftp-add-file-entry (path &optional dir-p) - "Given a PATH, add the file entry for it, if its directory -info exists." - (funcall (or (cdr (assq (ange-ftp-host-type - (car (ange-ftp-ftp-path path))) - ange-ftp-add-file-entry-alist)) - 'ange-ftp-internal-add-file-entry) - path dir-p) - (setq ange-ftp-ls-cache-file nil)) - -(defun ange-ftp-delete-file-entry (path &optional dir-p) - "Given a PATH, delete the file entry for it, if its directory -info exists." - (funcall (or (cdr (assq (ange-ftp-host-type - (car (ange-ftp-ftp-path path))) - ange-ftp-delete-file-entry-alist)) - 'ange-ftp-internal-delete-file-entry) - path dir-p) - (setq ange-ftp-ls-cache-file nil)) - -(defmacro ange-ftp-parse-filename () - ;;Extract the filename from the current line of a dired-like listing. - (` (let ((eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward ange-ftp-date-regexp eol t) - (progn - (skip-chars-forward " ") - (skip-chars-forward "^ " eol) - (skip-chars-forward " " eol) - ;; We bomb on filenames starting with a space. - (buffer-substring (point) eol)))))) - -;; This deals with the F switch. Should also do something about -;; unquoting names obtained with the SysV b switch and the GNU Q -;; switch. See Sebastian's dired-get-filename. - -(defmacro ange-ftp-ls-parser () - ;; Note that switches is dynamically bound. - ;; Meant to be called by ange-ftp-parse-dired-listing - (` (let ((tbl (ange-ftp-make-hashtable)) - (used-F (and (stringp switches) - (string-match "F" switches))) - file-type symlink directory file) - (while (setq file (ange-ftp-parse-filename)) - (beginning-of-line) - (skip-chars-forward "\t 0-9") - (setq file-type (following-char) - directory (eq file-type ?d)) - (if (eq file-type ?l) - (if (string-match " -> " file) - (setq symlink (substring file (match-end 0)) - file (substring file 0 (match-beginning 0))) - ;; Shouldn't happen - (setq symlink "")) - (setq symlink nil)) - ;; Only do a costly regexp search if the F switch was used. - (if (and used-F - (not (string-equal file "")) - (looking-at - ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)")) - (let ((socket (eq file-type ?s)) - (executable - (and (not symlink) ; x bits don't mean a thing for symlinks - (string-match "[xst]" - (concat - (buffer-substring - (match-beginning 1) - (match-end 1)) - (buffer-substring - (match-beginning 2) - (match-end 2)) - (buffer-substring - (match-beginning 3) - (match-end 3))))))) - ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX) - ;; and others don't. (sigh...) Beware, that some Unix's don't - ;; seem to believe in the F-switch - (if (or (and symlink (string-match "@$" file)) - (and directory (string-match "/$" file)) - (and executable (string-match "*$" file)) - (and socket (string-match "=$" file))) - (setq file (substring file 0 -1))))) - (ange-ftp-put-hash-entry file (or symlink directory) tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl) - tbl))) - -;;; The dl stuff for descriptive listings - -(defvar ange-ftp-dl-dir-regexp nil - "Regexp matching directories which are listed in dl format. This regexp -shouldn't be anchored with a trailing $ so that it will match subdirectories -as well.") - -(defun ange-ftp-add-dl-dir (dir) - "Interactively adds a given directory to ange-ftp-dl-dir-regexp." - (interactive - (list (read-string "Directory: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (ange-ftp-ftp-path name) - (file-name-directory name)))))) - (if (not (and ange-ftp-dl-dir-regexp - (string-match ange-ftp-dl-dir-regexp dir))) - (setq ange-ftp-dl-dir-regexp - (concat "^" (regexp-quote dir) - (and ange-ftp-dl-dir-regexp "\\|") - ange-ftp-dl-dir-regexp)))) - -(defmacro ange-ftp-dl-parser () - ;; Parse the current buffer, which is assumed to be a descriptive - ;; listing, and return a hashtable. - (` (let ((tbl (ange-ftp-make-hashtable))) - (while (not (eobp)) - (ange-ftp-put-hash-entry - (buffer-substring (point) - (progn - (skip-chars-forward "^ /\n") - (point))) - (eq (following-char) ?/) - tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl) - tbl))) - -(defun ange-ftp-parse-dired-listing (&optional switches) - "Parse the current buffer which is assumed to be in a dired-like listing -format, and return a hashtable as the result. If the listing is not really -a listing, then return nil." - (ange-ftp-save-match-data - (cond - ((looking-at "^total [0-9]+$") - (forward-line 1) - (ange-ftp-ls-parser)) - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. (zerop (buffer-size)) - ;; This could be one of: - ;; (1) An Ultrix ls error message - ;; (2) A listing with the A switch of an empty directory - ;; on a machine which doesn't give a total line. - ;; (3) The twilight zone. - ;; We'll assume (1) for now. - nil) - ((re-search-forward ange-ftp-date-regexp nil t) - (beginning-of-line) - (ange-ftp-ls-parser)) - ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t) - ;; It's a dl listing (I hope). - ;; file is bound by the call to ange-ftp-ls - (ange-ftp-add-dl-dir file) - (beginning-of-line) - (ange-ftp-dl-parser)) - (t nil)))) - -(defun ange-ftp-set-files (directory files) - "For a given DIRECTORY, set or change the associated FILES hashtable." - (and files (ange-ftp-put-hash-entry (file-name-as-directory directory) - files ange-ftp-files-hashtable))) - -(defun ange-ftp-get-files (directory &optional no-error) - "Given a given DIRECTORY, return a hashtable of file entries. -This will give an error or return nil, depending on the value of -NO-ERROR, if a listing for DIRECTORY cannot be obtained." - (setq directory (file-name-as-directory directory)) ;normalize - (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable) - (ange-ftp-save-match-data - (and (ange-ftp-ls directory - ;; This is an efficiency hack. We try to - ;; anticipate what sort of listing dired - ;; might want, and cache just such a listing. - (if (and (boundp 'dired-actual-switches) - (stringp dired-actual-switches) - ;; We allow the A switch, which lists - ;; all files except "." and "..". - ;; This is OK because we manually - ;; insert these entries - ;; in the hash table. - (string-match - "[aA]" dired-actual-switches) - (string-match - "l" dired-actual-switches) - (not (string-match - "R" dired-actual-switches))) - dired-actual-switches - (if (and (boundp 'dired-listing-switches) - (stringp dired-listing-switches) - (string-match - "[aA]" dired-listing-switches) - (string-match - "l" dired-listing-switches) - (not (string-match - "R" dired-listing-switches))) - dired-listing-switches - "-al")) - t no-error) - (ange-ftp-get-hash-entry - directory ange-ftp-files-hashtable))))) - -(defmacro ange-ftp-get-file-part (path) - "Given PATH, return the file part that can be used for looking up the -file's entry in a hashtable." - (` (let ((file (file-name-nondirectory (, path)))) - (if (string-equal file "") - "." - file)))) - -(defmacro ange-ftp-allow-child-lookup (dir file) - "Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are -allowed to determine if PATH is a sub-directory by listing it directly, -rather than listing its parent directory. This is used for efficiency so -that a wasted listing is not done: -1. When looking for a .dired file in dired-x.el. -2. The syntax of FILE and DIR make it impossible that FILE could be a valid - subdirectory. This is of course an OS dependent judgement." - (` (not - (let* ((efile (, file)) ; expand once. - (edir (, dir)) - (parsed (ange-ftp-ftp-path edir)) - (host-type (ange-ftp-host-type - (car parsed)))) - (or - ;; Deal with dired - (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file efile)) - ;; No dots in dir names in vms. - (and (eq host-type 'vms) - (string-match "\\." efile)) - ;; No subdirs in mts of cms. - (and (memq host-type '(mts cms)) - (not (string-equal "/" (nth 2 parsed))))))))) - -(defun ange-ftp-file-entry-p (path) - "Given PATH, return whether there is a file entry for it." - (let* ((path (directory-file-name path)) - (dir (file-name-directory path)) - (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) - (file (ange-ftp-get-file-part path))) - (if ent - (ange-ftp-hash-entry-exists-p file ent) - (or (and (ange-ftp-allow-child-lookup dir file) - (setq ent (ange-ftp-get-files path t)) - ;; Try a child lookup. i.e. try to list file as a - ;; subdirectory of dir. This is a good idea because - ;; we may not have read permission for file's parent. Also, - ;; people tend to work down directory trees anyway. We use - ;; no-error ;; because if file does not exist as a subdir., - ;; then dumb hosts will give an ftp error. Smart unix hosts - ;; will simply send back the ls - ;; error message. - (ange-ftp-get-hash-entry "." ent)) - ;; Child lookup failed. Try the parent. If this bombs, - ;; we are at wits end -- signal an error. - ;; Problem: If this signals an error, the error message - ;; may not have a lot to do with what went wrong. - (ange-ftp-hash-entry-exists-p file - (ange-ftp-get-files dir)))))) - -(defun ange-ftp-get-file-entry (path) - "Given PATH, return the given file entry which will be either t for a -directory, nil for a normal file, or a string for a symlink. If the file -isn't in the hashtable, this also returns nil." - (let* ((path (directory-file-name path)) - (dir (file-name-directory path)) - (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) - (file (ange-ftp-get-file-part path))) - (if ent - (ange-ftp-get-hash-entry file ent) - (or (and (ange-ftp-allow-child-lookup dir file) - (setq ent (ange-ftp-get-files path t)) - (ange-ftp-get-hash-entry "." ent)) - ;; i.e. it's a directory by child lookup - (ange-ftp-get-hash-entry file - (ange-ftp-get-files dir)))))) - -(defun ange-ftp-internal-delete-file-entry (path &optional dir-p) - (if dir-p - (progn - (setq path (file-name-as-directory path)) - (ange-ftp-del-hash-entry path ange-ftp-files-hashtable) - (setq path (directory-file-name path)))) - ;; Note that file-name-as-directory followed by directory-file-name - ;; serves to canonicalize directory file names to their unix form. - ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO - (let ((files (ange-ftp-get-hash-entry (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (ange-ftp-del-hash-entry (ange-ftp-get-file-part path) - files)))) - -(defun ange-ftp-internal-add-file-entry (path &optional dir-p) - (and dir-p - (setq path (directory-file-name path))) - (let ((files (ange-ftp-get-hash-entry (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (ange-ftp-put-hash-entry (ange-ftp-get-file-part path) - dir-p - files)))) - -(defun ange-ftp-wipe-file-entries (host user) - "Replace the file entry information hashtable with one that doesn't have any -entries for the given HOST, USER pair." - (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable)))) - (ange-ftp-map-hashtable - (function - (lambda (key val) - (let ((parsed (ange-ftp-ftp-path key))) - (if parsed - (let ((h (nth 0 parsed)) - (u (nth 1 parsed))) - (or (and (equal host h) (equal user u)) - (ange-ftp-put-hash-entry key val new-tbl))))))) - ange-ftp-files-hashtable) - (setq ange-ftp-files-hashtable new-tbl))) - -;;;; ------------------------------------------------------------ -;;;; File transfer mode support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-set-binary-mode (host user) - "Tell the ftp process for the given HOST & USER to switch to binary mode." - (let ((result (ange-ftp-send-cmd host user '(type "binary")))) - (if (not (car result)) - (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) - (save-excursion - (set-buffer (process-buffer (ange-ftp-get-process host user))) - (and ange-ftp-binary-hash-mark-size - (setq ange-ftp-hash-mark-unit (ash ange-ftp-binary-hash-mark-size -4))))))) - -(defun ange-ftp-set-ascii-mode (host user) - "Tell the ftp process for the given HOST & USER to switch to ascii mode." - (let ((result (ange-ftp-send-cmd host user '(type "ascii")))) - (if (not (car result)) - (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) - (save-excursion - (set-buffer (process-buffer (ange-ftp-get-process host user))) - (and ange-ftp-ascii-hash-mark-size - (setq ange-ftp-hash-mark-unit (ash ange-ftp-ascii-hash-mark-size -4))))))) - -;;; ------------------------------------------------------------ -;;; expand-file-name and friends... -;;; ------------------------------------------------------------ - -(defun ange-ftp-cd (host user dir) - (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD"))) - (or (car result) - (ange-ftp-error host user (concat "CD failed: " (cdr result)))))) - -(defun ange-ftp-get-pwd (host user) - "Attempts to get the current working directory for the given HOST/USER pair. -Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, -and LINE is the relevant success or fail line from the FTP-client." - (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD")) - (line (cdr result)) - dir) - (if (car result) - (ange-ftp-save-match-data - (and (or (string-match "\"\\([^\"]*\\)\"" line) - (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers! - (setq dir (substring line - (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable)) - -(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):") - -(defun ange-ftp-expand-dir (host user dir) - "Return the result of doing a PWD in the current FTP session to machine HOST -logged in as user USER and cd'd to directory DIR." - (let* ((host-type (ange-ftp-host-type host user)) - ;; It is more efficient to call ange-ftp-host-type - ;; before binding res, because ange-ftp-host-type sometimes - ;; adds to the info in the expand-dir-hashtable. - (fix-pathname-func - (cdr (assq host-type ange-ftp-fix-path-func-alist))) - (key (concat host "/" user "/" dir)) - (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable))) - (or res - (progn - (or - (string-equal user "anonymous") - (string-equal user "ftp") - (not (eq host-type 'unix)) - (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp - "\\|" - ange-ftp-good-msgs)) - (result (ange-ftp-send-cmd host user - (list 'get dir "/dev/null") - (format "expanding %s" dir))) - (line (cdr result))) - (setq res - (if (string-match ange-ftp-expand-dir-regexp line) - (substring line - (match-beginning 1) - (match-end 1)))))) - (or res - (if (string-equal dir "~") - (setq res (car (ange-ftp-get-pwd host user))) - (let ((home (ange-ftp-expand-dir host user "~"))) - (unwind-protect - (and (ange-ftp-cd host user dir) - (setq res (car (ange-ftp-get-pwd host user)))) - (ange-ftp-cd host user home))))) - (if res - (progn - (if fix-pathname-func - (setq res (funcall fix-pathname-func res 'reverse))) - (ange-ftp-put-hash-entry - key res ange-ftp-expand-dir-hashtable))) - res)))) - -(defun ange-ftp-canonize-filename (n) - "Take a string and short-circuit //, /. and /.." - (if (string-match "[^:]+//" n) ;don't upset Apollo users - (setq n (substring n (1- (match-end 0))))) - (let ((parsed (ange-ftp-ftp-path n))) - (if parsed - (let ((host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - - ;; See if remote path is absolute. If so then just expand it and - ;; replace the path component of the overall path. - (cond ((string-match "^/" path) - path) - - ;; Path starts with ~ or ~user. Resolve that part of the path - ;; making it absolute then re-expand it. - ((string-match "^~[^/]*" path) - (let* ((tilda (substring path - (match-beginning 0) - (match-end 0))) - (rest (substring path (match-end 0))) - (dir (ange-ftp-expand-dir host user tilda))) - (if dir - (setq path (concat dir rest)) - (error "User \"%s\" is not known" - (substring tilda 1))))) - - ;; relative path. Tack on homedir and re-expand. - (t - (let ((dir (ange-ftp-expand-dir host user "~"))) - (if dir - (setq path (concat - (ange-ftp-real-file-name-as-directory dir) - path)) - (error "Unable to obtain CWD"))))) - - (if (not (string-match "^//" path)) - (progn - (setq path (ange-ftp-real-expand-file-name path)) - - (if (string-match "^//" path) - (setq path (substring path 1))))) - - ;; Now substitute the expanded path back into the overall filename. - (ange-ftp-replace-path-component n path)) - - ;; non-ange-ftp path. Just expand normally. - (if (eq (string-to-char n) ?/) - (ange-ftp-real-expand-file-name n) - (ange-ftp-real-expand-file-name - (ange-ftp-real-file-name-nondirectory n) - (ange-ftp-real-file-name-directory n)))))) - -(defun ange-ftp-expand-file-name (name &optional default) - "Documented as original." - (ange-ftp-save-match-data - (if (eq (string-to-char name) ?/) - (while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users - (setq name (substring name (1- (match-end 0))))) - ((string-match "/~" name) - (setq name (substring name (1- (match-end 0)))))))) - (cond ((eq (string-to-char name) ?~) - (ange-ftp-real-expand-file-name name)) - ((eq (string-to-char name) ?/) - (ange-ftp-canonize-filename name)) - ((zerop (length name)) - (ange-ftp-canonize-filename (or default default-directory))) - ((ange-ftp-canonize-filename - (concat (file-name-as-directory (or default default-directory)) - name)))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinitions of standard GNU Emacs functions. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-file-name-as-directory-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where -FUNC converts a filename to a directory name for the operating -system TYPE.") - -(defun ange-ftp-file-name-as-directory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (if (string-equal (nth 2 parsed) "") - name - (funcall (or (cdr (assq - (ange-ftp-host-type (car parsed)) - ange-ftp-file-name-as-directory-alist)) - 'ange-ftp-real-file-name-as-directory) - name)) - (ange-ftp-real-file-name-as-directory name)))) - -(defun ange-ftp-file-name-directory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (let ((path (nth 2 parsed))) - (if (ange-ftp-save-match-data - (string-match "^~[^/]*$" path)) - name - (ange-ftp-replace-path-component - name - (ange-ftp-real-file-name-directory path)))) - (ange-ftp-real-file-name-directory name)))) - -(defun ange-ftp-file-name-nondirectory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (let ((path (nth 2 parsed))) - (if (ange-ftp-save-match-data - (string-match "^~[^/]*$" path)) - "" - (ange-ftp-real-file-name-nondirectory path))) - (ange-ftp-real-file-name-nondirectory name)))) - -(defun ange-ftp-directory-file-name (dir) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (ange-ftp-replace-path-component - dir - (ange-ftp-real-directory-file-name (nth 2 parsed))) - (ange-ftp-real-directory-file-name dir)))) - -(defun ange-ftp-binary-file (file) - "Returns whether the given FILE is to be considered as a binary file for -ftp transfers." - (ange-ftp-save-match-data - (string-match ange-ftp-binary-file-name-regexp file))) - -;;; 20.0-b92 change (see jka-compr) -(defun ange-ftp-write-region (start end filename &optional append visit - lockname coding-system) - "Documented as original." - (interactive "r\nFWrite region to file: ") - (setq filename (expand-file-name filename)) - (let ((parsed (ange-ftp-ftp-path filename))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) - (cmd (if append 'append 'put)) - (abbr (ange-ftp-abbreviate-filename filename))) - (unwind-protect - (progn - (let ((executing-macro t) - (filename (buffer-file-name)) - (mod-p (buffer-modified-p))) - (unwind-protect - (ange-ftp-real-write-region start end temp nil - visit lockname coding-system) - ;; cleanup forms - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)) - (set-buffer-modified-p mod-p))) - (if binary - (ange-ftp-set-binary-mode host user)) - - ;; tell the process filter what size the transfer will be. - (let ((attr (file-attributes temp))) - (if attr - (ange-ftp-set-xfer-size host user (nth 7 attr)))) - - ;; put or append the file. - (let ((result (ange-ftp-send-cmd host user - (list cmd temp path) - (format "Writing %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Opening output file" - (format "FTP Error: \"%s\"" (cdr result)) - filename))))) - (ange-ftp-del-tmp-name temp) - (if binary - (ange-ftp-set-ascii-mode host user))) - (if (eq visit t) - (progn - (ange-ftp-set-buffer-mode) - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)) - (set-buffer-modified-p nil))) - (ange-ftp-message "Wrote %s" abbr) - (ange-ftp-add-file-entry filename)) - (ange-ftp-real-write-region start end filename append visit lockname coding-system)))) - -(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace) - "Documented as original." - (barf-if-buffer-read-only) - (setq filename (expand-file-name filename)) - (let ((parsed (ange-ftp-ftp-path filename))) - (if parsed - (progn - (if visit - (progn - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)))) - (if (or (file-exists-p filename) - (progn - (setq ange-ftp-ls-cache-file nil) - (ange-ftp-del-hash-entry (file-name-directory filename) - ange-ftp-files-hashtable) - (file-exists-p filename))) - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) - (abbr (ange-ftp-abbreviate-filename filename)) - size) - (unwind-protect - (progn - (if binary - (ange-ftp-set-binary-mode host user)) - (let ((result (ange-ftp-send-cmd host user - (list 'get path temp) - (format "Retrieving %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Opening input file" - (format "FTP Error: \"%s\"" (cdr result)) - filename)))) - (if (or (ange-ftp-real-file-readable-p temp) - (sleep-for ange-ftp-retry-time) - ;; Wait for file to hopefully appear. - (ange-ftp-real-file-readable-p temp)) - (setq - size - (nth 1 (progn - (if replace ; kludge... - (delete-region (point-min) - (point-max))) - (ange-ftp-real-insert-file-contents - temp visit beg end nil)))) - (signal 'ftp-error - (list - "Opening input file:" - (format - "FTP Error: %s not arrived or readable" - filename))))) - (if binary - (ange-ftp-set-ascii-mode host user)) - (ange-ftp-del-tmp-name temp)) - (if visit - (progn - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)))) - (list filename size)) - (signal 'file-error - (list - "Opening input file" - filename)))) - (ange-ftp-real-insert-file-contents filename visit beg end replace)))) - -(defun ange-ftp-revert-buffer (arg noconfirm) - "Revert this buffer from a remote file using ftp." - (let ((opoint (point))) - (cond ((null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - ((or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - buffer-file-name))) - (let ((buffer-read-only nil)) - ;; Set buffer-file-name to nil - ;; so that we don't try to lock the file. - (let ((buffer-file-name nil)) - (unlock-buffer) - (erase-buffer)) - (insert-file-contents buffer-file-name t)) - (goto-char (min opoint (point-max))) - (after-find-file nil) - t)))) - -(defun ange-ftp-expand-symlink (file dir) - (if (file-name-absolute-p file) - (ange-ftp-replace-path-component dir file) - (expand-file-name file dir))) - -(defun ange-ftp-file-symlink-p (file) - "Documented as original." - ;; call ange-ftp-expand-file-name rather than the normal - ;; expand-file-name to stop loops when using a package that - ;; redefines both file-symlink-p and expand-file-name. - (setq file (ange-ftp-expand-file-name file)) - (if (ange-ftp-ftp-path file) - (let ((file-ent - (ange-ftp-get-hash-entry - (ange-ftp-get-file-part file) - (ange-ftp-get-files (file-name-directory file))))) - (if (stringp file-ent) - (if (file-name-absolute-p file-ent) - (ange-ftp-replace-path-component - (file-name-directory file) file-ent) - file-ent))) - (ange-ftp-real-file-symlink-p file))) - -(defun ange-ftp-file-exists-p (path) - "Documented as original." - (setq path (expand-file-name path)) - (if (ange-ftp-ftp-path path) - (if (ange-ftp-file-entry-p path) - (let ((file-ent (ange-ftp-get-file-entry path))) - (if (stringp file-ent) - (file-exists-p - (ange-ftp-expand-symlink file-ent - (file-name-directory - (directory-file-name path)))) - t))) - (ange-ftp-real-file-exists-p path))) - -(defun ange-ftp-file-directory-p (path) - "Documented as original." - (setq path (expand-file-name path)) - (if (ange-ftp-ftp-path path) - ;; We do a file-name-as-directory on path here because some - ;; machines (VMS) use a .DIR to indicate the filename associated - ;; with a directory. This needs to be canonicalized. - (let ((file-ent (ange-ftp-get-file-entry - (ange-ftp-file-name-as-directory path)))) - (if (stringp file-ent) - (file-directory-p - (ange-ftp-expand-symlink file-ent - (file-name-directory - (directory-file-name path)))) - file-ent)) - (ange-ftp-real-file-directory-p path))) - -(defun ange-ftp-directory-files (directory &optional full match - &rest v19-args) - "Documented as original." - (setq directory (expand-file-name directory)) - (if (ange-ftp-ftp-path directory) - (progn - (ange-ftp-barf-if-not-directory directory) - (let ((tail (ange-ftp-hash-table-keys - (ange-ftp-get-files directory))) - files f) - (setq directory (file-name-as-directory directory)) - (ange-ftp-save-match-data - (while tail - (setq f (car tail) - tail (cdr tail)) - (if (or (not match) (string-match match f)) - (setq files - (cons (if full (concat directory f) f) files))))) - (nreverse files))) - (apply 'ange-ftp-real-directory-files directory full match v19-args))) - -(defun ange-ftp-file-attributes (file) - "Documented as original." - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let ((part (ange-ftp-get-file-part file)) - (files (ange-ftp-get-files (file-name-directory file)))) - (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (dirp (ange-ftp-get-hash-entry part files))) - (list (if (and (stringp dirp) (file-name-absolute-p dirp)) - (ange-ftp-expand-symlink dirp - (file-name-directory file)) - dirp) ;0 file type - -1 ;1 link count - -1 ;2 uid - -1 ;3 gid - '(0 0) ;4 atime - '(0 0) ;5 mtime - '(0 0) ;6 ctime - -1 ;7 size - (concat (if (stringp dirp) "l" (if dirp "d" "-")) - "?????????") ;8 mode - nil ;9 gid weird - ;; Hack to give remote files a unique "inode number". - ;; It's actually the sum of the characters in its name. - (apply '+ (nconc (mapcar 'identity host) - (mapcar 'identity user) - (mapcar 'identity - (directory-file-name path)))) - -1 ;11 device number [v19 only] - )))) - (ange-ftp-real-file-attributes file)))) - -(defun ange-ftp-file-writable-p (file) - "Documented as original." - (setq file (expand-file-name file)) - (if (ange-ftp-ftp-path file) - (or (file-exists-p file) ;guess here for speed - (file-directory-p (file-name-directory file))) - (ange-ftp-real-file-writable-p file))) - -(defun ange-ftp-file-readable-p (file) - "Documented as original." - (setq file (expand-file-name file)) - (if (ange-ftp-ftp-path file) - (file-exists-p file) - (ange-ftp-real-file-readable-p file))) - -(defun ange-ftp-delete-file (file) - "Documented as original." - (interactive "fDelete file: ") - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (result (ange-ftp-send-cmd host user - (list 'delete path) - (format "Deleting %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Removing old name" - (format "FTP Error: \"%s\"" (cdr result)) - file))) - (ange-ftp-delete-file-entry file)) - (ange-ftp-real-delete-file file)))) - -(defun ange-ftp-verify-visited-file-modtime (buf) - "Documented as original." - (let ((name (buffer-file-name buf))) - (if (and (stringp name) (ange-ftp-ftp-path name)) - t - (ange-ftp-real-verify-visited-file-modtime buf)))) - -(defun ange-ftp-backup-buffer () - "Documented as original." - (let (parsed) - (if (and - (listp ange-ftp-make-backup-files) - (stringp buffer-file-name) - (setq parsed (ange-ftp-ftp-path buffer-file-name)) - (or - (null ange-ftp-make-backup-files) - (not - (memq - (ange-ftp-host-type - (car parsed)) - ange-ftp-make-backup-files)))) - nil - (ange-ftp-real-backup-buffer)))) - -;;;; ------------------------------------------------------------ -;;;; File copying support... totally re-written 6/24/92. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive) - (if (file-exists-p absname) - (if (not interactive) - (signal 'file-already-exists (list absname)) - (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " - absname querystring))) - (signal 'file-already-exists (list absname)))))) - -;; async local copy commented out for now since I don't seem to get -;; the process sentinel called for some processes. -;; -;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists -;; keep-date cont) -;; "Kludge to copy a local file and call a continuation when the copy -;; finishes." -;; ;; check to see if we can overwrite -;; (if (or (not ok-if-already-exists) -;; (numberp ok-if-already-exists)) -;; (ange-ftp-barf-or-query-if-file-exists newname "copy to it" -;; (numberp ok-if-already-exists))) -;; (let ((proc (start-process " *copy*" -;; (generate-new-buffer "*copy*") -;; "cp" -;; filename -;; newname)) -;; res) -;; (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel)) -;; (process-kill-without-query proc) -;; (save-excursion -;; (set-buffer (process-buffer proc)) -;; (make-variable-buffer-local 'copy-cont) -;; (setq copy-cont cont)))) -;; -;; (defun ange-ftp-copy-file-locally-sentinel (proc status) -;; (save-excursion -;; (set-buffer (process-buffer proc)) -;; (let ((cont copy-cont) -;; (result (buffer-string))) -;; (unwind-protect -;; (if (and (string-equal status "finished\n") -;; (zerop (length result))) -;; (ange-ftp-call-cont cont t nil) -;; (ange-ftp-call-cont cont -;; nil -;; (if (zerop (length result)) -;; (substring status 0 -1) -;; (substring result 0 -1)))) -;; (kill-buffer (current-buffer)))))) - -;; this is the extended version of ange-ftp-copy-file-internal that works -;; asyncronously if asked nicely. -(defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists - keep-date &optional msg cont nowait) - (setq filename (expand-file-name filename) - newname (expand-file-name newname)) - - ;; canonicalize newname if a directory. - (if (file-directory-p newname) - (setq newname (expand-file-name (file-name-nondirectory filename) newname))) - - (let ((f-parsed (ange-ftp-ftp-path filename)) - (t-parsed (ange-ftp-ftp-path newname))) - - ;; local file to local file copy? - (if (and (not f-parsed) (not t-parsed)) - (progn - (ange-ftp-real-copy-file filename newname ok-if-already-exists - keep-date) - (if cont - (ange-ftp-call-cont cont t "Copied locally"))) - ;; one or both files are remote. - (let* ((f-host (and f-parsed (nth 0 f-parsed))) - (f-user (and f-parsed (nth 1 f-parsed))) - (f-path (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed)))) - (f-abbr (ange-ftp-abbreviate-filename filename)) - (t-host (and t-parsed (nth 0 t-parsed))) - (t-user (and t-parsed (nth 1 t-parsed))) - (t-path (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed)))) - (t-abbr (ange-ftp-abbreviate-filename newname filename)) - (binary (or (ange-ftp-binary-file filename) - (ange-ftp-binary-file newname))) - temp1 - temp2) - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (ange-ftp-barf-or-query-if-file-exists newname "copy to it" - (numberp ok-if-already-exists))) - - ;; do the copying. - (if f-parsed - - ;; filename was remote. - (progn - (if (or (ange-ftp-use-gateway-p f-host) - t-parsed) - ;; have to use intermediate file if we are getting via - ;; gateway machine or we are doing a remote to remote copy. - (setq temp1 (ange-ftp-make-tmp-name f-host))) - - (if binary - (ange-ftp-set-binary-mode f-host f-user)) - - (ange-ftp-send-cmd - f-host - f-user - (list 'get f-path (or temp1 newname)) - (or msg - (if (and temp1 t-parsed) - (format "Getting %s" f-abbr) - (format "Copying %s to %s" f-abbr t-abbr))) - (list (function ange-ftp-cf1) - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - temp1 temp2 cont nowait) - nowait)) - - ;; filename wasn't remote. newname must be remote. call the - ;; function which does the remainder of the copying work. - (ange-ftp-cf1 t nil - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - nil nil cont nowait)))))) - -;; next part of copying routine. -(defun ange-ftp-cf1 (result line - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - temp1 temp2 cont nowait) - (if line - ;; filename must have been remote, and we must have just done a GET. - (unwind-protect - (or result - ;; GET failed for some reason. Clean up and get out. - (progn - (and temp1 (ange-ftp-del-tmp-name temp1)) - (or cont - (signal 'ftp-error (list "Opening input file" - (format "FTP Error: \"%s\"" line) - filename))))) - ;; cleanup - (if binary - (ange-ftp-set-ascii-mode f-host f-user)))) - - (if result - ;; We now have to copy either temp1 or filename to newname. - (if t-parsed - - ;; newname was remote. - (progn - (if (ange-ftp-use-gateway-p t-host) - (setq temp2 (ange-ftp-make-tmp-name t-host))) - - ;; make sure data is moved into the right place for the - ;; outgoing transfer. gateway temporary files complicate - ;; things nicely. - (if temp1 - (if temp2 - (if (string-equal temp1 temp2) - (setq temp1 nil) - (ange-ftp-real-copy-file temp1 temp2 t)) - (setq temp2 temp1 temp1 nil)) - (if temp2 - (ange-ftp-real-copy-file filename temp2 t))) - - (if binary - (ange-ftp-set-binary-mode t-host t-user)) - - ;; tell the process filter what size the file is. - (let ((attr (file-attributes (or temp2 filename)))) - (if attr - (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) - - (ange-ftp-send-cmd - t-host - t-user - (list 'put (or temp2 filename) t-path) - (or msg - (if (and temp2 f-parsed) - (format "Putting %s" newname) - (format "Copying %s to %s" f-abbr t-abbr))) - (list (function ange-ftp-cf2) - newname t-host t-user binary temp1 temp2 cont) - nowait)) - - ;; newname wasn't remote. - (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont)) - - ;; first copy failed, tell caller - (ange-ftp-call-cont cont result line))) - -;; last part of copying routine. -(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont) - (unwind-protect - (if line - ;; result from doing a local to remote copy. - (unwind-protect - (progn - (or result - (or cont - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\"" line) - newname)))) - - (ange-ftp-add-file-entry newname)) - - ;; cleanup. - (if binary - (ange-ftp-set-ascii-mode t-host t-user))) - - ;; newname was local. - (if temp1 - (ange-ftp-real-copy-file temp1 newname t))) - - ;; clean up - (and temp1 (ange-ftp-del-tmp-name temp1)) - (and temp2 (ange-ftp-del-tmp-name temp2)) - (ange-ftp-call-cont cont result line))) - -(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date) - "Documented as original." - (interactive "fCopy file: \nFCopy %s to file: \np") - (ange-ftp-copy-file-internal filename - newname - ok-if-already-exists - keep-date - nil - nil - (interactive-p))) - -;;;; ------------------------------------------------------------ -;;;; File renaming support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed - binary) - "Rename remote file FILE to remote file NEWNAME." - (let ((f-host (nth 0 f-parsed)) - (f-user (nth 1 f-parsed)) - (t-host (nth 0 t-parsed)) - (t-user (nth 1 t-parsed))) - (if (and (string-equal f-host t-host) - (string-equal f-user t-user)) - (let* ((f-path (ange-ftp-quote-string (nth 2 f-parsed))) - (t-path (ange-ftp-quote-string (nth 2 t-parsed))) - (cmd (list 'rename f-path t-path)) - (fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (result (ange-ftp-send-cmd f-host f-user cmd - (format "Renaming %s to %s" - fabbr - nabbr)))) - (or (car result) - (signal 'ftp-error - (list - "Renaming" - (format "FTP Error: \"%s\"" (cdr result)) - filename - newname))) - (ange-ftp-add-file-entry newname) - (ange-ftp-delete-file-entry filename)) - (ange-ftp-copy-file-internal filename newname t nil) - (delete-file filename)))) - -(defun ange-ftp-rename-local-to-remote (filename newname) - "Rename local FILE to remote file NEWNAME." - (let* ((fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (msg (format "Renaming %s to %s" fabbr nabbr))) - (ange-ftp-copy-file-internal filename newname t nil msg) - (let (ange-ftp-process-verbose) - (delete-file filename)))) - -(defun ange-ftp-rename-remote-to-local (filename newname) - "Rename remote file FILE to local file NEWNAME." - (let* ((fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (msg (format "Renaming %s to %s" fabbr nabbr))) - (ange-ftp-copy-file-internal filename newname t nil msg) - (let (ange-ftp-process-verbose) - (delete-file filename)))) - -(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists) - "Documented as original." - (interactive "fRename file: \nFRename %s to file: \np") - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (let* ((f-parsed (ange-ftp-ftp-path filename)) - (t-parsed (ange-ftp-ftp-path newname)) - (binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename)))) - (if (and (or f-parsed t-parsed) - (or (not ok-if-already-exists) - (numberp ok-if-already-exists))) - (ange-ftp-barf-or-query-if-file-exists - newname - "rename to it" - (numberp ok-if-already-exists))) - (if f-parsed - (if t-parsed - (ange-ftp-rename-remote-to-remote filename newname f-parsed - t-parsed binary) - (ange-ftp-rename-remote-to-local filename newname)) - (if t-parsed - (ange-ftp-rename-local-to-remote filename newname) - (ange-ftp-real-rename-file filename newname ok-if-already-exists))))) - -;;;; ------------------------------------------------------------ -;;;; Classic Dired support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-dired-host-type nil - "The host type associated with a dired buffer. (buffer local)") -(make-variable-buffer-local 'ange-ftp-dired-host-type) - -(defun ange-ftp-dired-readin (dirname buffer) - "Documented as original." - (let ((file (ange-ftp-abbreviate-filename dirname)) - (parsed (ange-ftp-ftp-path dirname))) - (save-excursion - (ange-ftp-message "Reading directory %s..." file) - (set-buffer buffer) - (let ((buffer-read-only nil)) - (widen) - (erase-buffer) - (setq dirname (expand-file-name dirname)) - (if parsed - (let ((host-type (ange-ftp-host-type (car parsed)))) - (setq ange-ftp-dired-host-type host-type) - (insert (ange-ftp-ls dirname dired-listing-switches t))) - (if (ange-ftp-real-file-directory-p dirname) - (call-process "ls" nil buffer nil - dired-listing-switches dirname) - (let ((default-directory - (ange-ftp-real-file-name-directory dirname))) - (call-process - shell-file-name nil buffer nil - "-c" (concat - "ls " dired-listing-switches " " - (ange-ftp-real-file-name-nondirectory dirname)))))) - (goto-char (point-min)) - (while (not (eobp)) - (insert " ") - (forward-line 1)) - (goto-char (point-min)))) - (ange-ftp-message "Reading directory %s...done" file))) - -(defun ange-ftp-dired-revert (&optional arg noconfirm) - "Documented as original." - (if (and dired-directory - (ange-ftp-ftp-path (expand-file-name dired-directory))) - (setq ange-ftp-ls-cache-file nil)) - (ange-ftp-real-dired-revert arg noconfirm)) - -;;;; ------------------------------------------------------------ -;;;; Tree Dired support (ange & Sebastian Kremer) -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-dired-re-exe-alist nil - "Association list of regexps \(strings\) which match file lines of - executable files.") - -(defvar ange-ftp-dired-re-dir-alist nil - "Association list of regexps \(strings\) which match file lines of - subdirectories.") - -(defvar ange-ftp-dired-insert-headerline-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to insert the headerline of -the dired buffer.") - -(defvar ange-ftp-dired-move-to-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to move to the beginning of a -filename.") - -(defvar ange-ftp-dired-move-to-end-of-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to move to the end of a -filename.") - -(defvar ange-ftp-dired-get-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to get a filename from the -current line.") - -(defvar ange-ftp-dired-between-files-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to determine when the point -is on a line between files.") - -(defvar ange-ftp-dired-ls-trim-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a function which trims extraneous lines from a directory listing.") - -(defvar ange-ftp-dired-clean-directory-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a function which cleans out old versions of files in the OS TYPE.") - -(defvar ange-ftp-dired-flag-backup-files-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a functions which flags the backup files for deletion in the OS TYPE.") - -(defvar ange-ftp-dired-backup-diff-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC diffs -a file with its backup. The backup file is determined according to -the OS TYPE.") - -;; Could use dired-before-readin-hook here, instead of overloading -;; dired-readin. However, if people change this hook after ange-ftp -;; is loaded, they'll break things. -;; Also, why overload dired-readin rather than dired-mode? -;; Because I don't want to muck up virtual dired (see dired-x.el). - -(defun ange-ftp-tree-dired-readin (dirname buffer) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path dirname))) - (if parsed - (save-excursion - (set-buffer buffer) - (setq ange-ftp-dired-host-type - (ange-ftp-host-type (car parsed))) - (and ange-ftp-dl-dir-regexp - (eq ange-ftp-dired-host-type 'unix) - (string-match ange-ftp-dl-dir-regexp dirname) - (setq ange-ftp-dired-host-type 'unix:dl)) - (let ((eentry (assq ange-ftp-dired-host-type - ange-ftp-dired-re-exe-alist)) - (dentry (assq ange-ftp-dired-host-type - ange-ftp-dired-re-dir-alist))) - (if eentry - (set (make-local-variable 'dired-re-exe) (cdr eentry))) - (if dentry - (set (make-local-variable 'dired-re-dir) (cdr dentry))) - ;; No switches are sent to dumb hosts, so don't confuse dired. - ;; I hope that dired doesn't get excited if it doesn't see the l - ;; switch. If it does, then maybe fake things by setting this to - ;; "-Al". - (if (memq ange-ftp-dired-host-type ange-ftp-dumb-host-types) - (setq dired-actual-switches "-Al")))))) - (ange-ftp-real-dired-readin dirname buffer)) - -(defun ange-ftp-dired-insert-headerline (dir) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-insert-headerline-alist))) - 'ange-ftp-real-dired-insert-headerline) - dir)) - -(defun ange-ftp-dired-move-to-filename (&optional raise-error eol) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-move-to-filename-alist))) - 'ange-ftp-real-dired-move-to-filename) - raise-error eol)) - -(defun ange-ftp-dired-move-to-end-of-filename (&optional no-error) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-move-to-end-of-filename-alist))) - 'ange-ftp-real-dired-move-to-end-of-filename) - no-error)) - -(defun ange-ftp-dired-get-filename (&optional localp no-error-if-not-filep) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-get-filename-alist))) - 'ange-ftp-real-dired-get-filename) - localp no-error-if-not-filep)) - -(defun ange-ftp-dired-between-files () - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-between-files-alist))) - 'ange-ftp-real-dired-between-files))) - -(defvar ange-ftp-bob-version-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC is -a function to be used to bob the version number off of a filename -in OS TYPE.") - -(defun ange-ftp-dired-find-file () - "Documented as original." - (interactive) - (find-file (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-bob-version-alist))) - 'identity) - (dired-get-filename)))) - -;; Need the following functions for making filenames of compressed -;; files, because some OS's (unlike UNIX) do not allow a filename to -;; have two extensions. - -(defvar ange-ftp-dired-compress-make-compressed-filename-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC converts a -filename to the filename of the associated compressed file.") - -;;; this overwrites dired's `dired-compress-make-compressed-filename' -(defun ange-ftp-dired-compress-make-compressed-filename (name &optional reverse) - "Converts a filename to the filename of the associated compressed -file. With an optional reverse argument, the reverse conversion is done. - -Modified to work with gzip (GNU zip) files." - (let ((parsed (ange-ftp-ftp-path name)) - conversion-func) - (if (and parsed - (setq conversion-func - (cdr (assq (ange-ftp-host-type (car parsed)) - ange-ftp-dired-compress-make-compressed-filename-alist)))) - (funcall conversion-func name reverse) - (if reverse - - ;; uncompress... - ;; return `nil' if no match found -- better than nothing - (let (case-fold-search ; case-sensitive search - (string - (concat "\\.\\(g?z\\|" (regexp-quote dired-gzip-file-extension) - "$\\|Z\\)$"))) - - (and (string-match string name) - (substring name 0 (match-beginning 0)))) - - ;; add appropriate extension - ;; note: it could be that `gz' is not the proper extension for gzip - (concat name - (if dired-use-gzip-instead-of-compress - dired-gzip-file-extension ".Z")))))) - -(defun ange-ftp-dired-clean-directory (keep) - "Documented as original." - (interactive "P") - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-clean-directory-alist))) - 'ange-ftp-real-dired-clean-directory) - keep)) - -(defun ange-ftp-dired-backup-diff (&optional switches) - "Documented as original." - (interactive (list (if (fboundp 'diff-read-switches) - (diff-read-switches "Diff with switches: ")))) - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-backup-diff-alist))) - 'ange-ftp-real-dired-backup-diff) - switches)) - - -(defun ange-ftp-dired-fixup-subdirs (start file) - "Turn each subdir name into a valid ange-ftp filename." - - ;; We haven't indented the listing yet. - ;; Must be careful about filelines ending in a colon: exclude spaces! - (let ((subdir-regexp "^\\([^ \n\r]+\\)\\(:\\)[\n\r]")) - (save-restriction - (save-excursion - (narrow-to-region start (point)) - (goto-char start) - (while (re-search-forward subdir-regexp nil t) - (goto-char (match-beginning 1)) - (let ((name (buffer-substring (point) - (match-end 1)))) - (delete-region (point) (match-end 1)) - (insert (ange-ftp-replace-path-component - file - name)))))))) - -(defun ange-ftp-dired-ls (file switches &optional wildcard full-directory-p) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((pt (point)) - (path (nth 2 parsed)) - (host-type (ange-ftp-host-type (car parsed))) - (dumb (memq host-type ange-ftp-dumb-host-types)) - trim-func case-fold-search) - ;; Make sure that case-fold-search is nil - ;; so that we can look at the switches. - (if wildcard - (if (not (memq host-type '(unix dumb-unix))) - (insert (ange-ftp-ls file switches nil)) - ;; Prevent ls from inserting subdirs, as the subdir header - ;; line format would be wrong (it would have no "/user@host:" - ;; prefix) - (insert (ange-ftp-ls file (concat switches "d") nil)) - - ;; Quoting the path part of the file name seems to be a good - ;; idea (using dired.el's shell-quote function), but ftpd - ;; always globs ls args before passing them to /bin/ls or even - ;; doing the ls formatting itself. --> So wildcard characters - ;; in FILE lose. Sigh... - - ;; When using wildcards, some ftpd's put the whole directory - ;; name in front of each filename. Walk down the listing - ;; generated and remove this stuff. - (let ((dir (ange-ftp-real-file-name-directory path))) - (if dir - (let ((dirq (regexp-quote dir))) - (save-restriction - (save-excursion - (narrow-to-region pt (point)) - (goto-char pt) - (while (not (eobp)) - (if (dired-move-to-filename) - (if (re-search-forward dirq nil t) - (replace-match ""))) - (forward-line 1)))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Big issue here Andy! ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; In tree dired V5.245 Sebastian has used the following - ;; trick to resolve symbolic links to directories. This causes - ;; havoc with ange-ftp, because ange-ftp expands dots, with - ;; expand-file-name before it sends them. This means that this - ;; trick currently fails for remote SysV machines. But worse, - ;; /vms:/DEV:/FOO/. expands to /vms:/DEV:/FOO, which converts - ;; to DEV:FOO and not DEV:[FOO]. i.e it is only in UNIX that - ;; we can play fast and loose with the difference between - ;; directory names and their associated filenames. - ;; My temporary fix is to knock Sebastian's dot off. - ;; Maybe things can be made real clever in - ;; the future, so that Sebastian can have his way with remote - ;; SysV machines. - ;; Sebastian in dired-readin-insert says: - - ;; On SysV derived system, symbolic links to - ;; directories are not resolved, while on BSD - ;; derived it suffices to let DIRNAME end in slash. - ;; We always let it end in "/." since it does no - ;; harm on BSD and makes Dired work on such links on - ;; SysV. - - (if (string-match "/\\.$" path) - (setq - file - (ange-ftp-replace-path-component - file (substring path 0 -1)))) - (if (string-match "R" switches) - (progn - (insert (ange-ftp-ls file switches nil)) - ;; fix up the subdirectory names in the recursive - ;; listing. - (ange-ftp-dired-fixup-subdirs pt file)) - (insert - (ange-ftp-ls file - switches - (and (or dumb (string-match "[aA]" switches)) - full-directory-p)))) - (if (and (null full-directory-p) - (setq trim-func - (cdr (assq host-type - ange-ftp-dired-ls-trim-alist)))) - ;; If full-directory-p and wild-card are null, then only one - ;; line per file must be inserted. - ;; Some OS's (like VMS) insert other crap. Clean it out. - (save-restriction - (narrow-to-region pt (point)) - (funcall trim-func))))) - (ange-ftp-real-dired-ls file switches wildcard full-directory-p)))) - -(defvar ange-ftp-remote-shell-file-name - (if (memq system-type '(hpux usg-unix-v)) ; hope that's right - "remsh" - "rsh") - "Remote shell used by ange-ftp.") - -(defun ange-ftp-dired-run-shell-command (command &optional in-background) - "Documented as original." - (let* ((parsed (ange-ftp-ftp-path default-directory)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - (if (not parsed) - (ange-ftp-real-dired-run-shell-command command in-background) - (if (> (length path) 0) ; else it's $HOME - (setq command (concat "cd " path "; " command))) - (setq command - (format "%s %s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - ange-ftp-remote-shell-file-name host command)) - (ange-ftp-message "Remote command '%s' ..." command) - ;; Cannot call ange-ftp-real-dired-run-shell-command here as it - ;; would prepend "cd default-directory" --- which bombs because - ;; default-directory is in ange-ftp syntax for remote path names. - (if in-background - (comint::background command) - (shell-command command))))) - -(defun ange-ftp-make-directory (dir &optional parents) - "Documented as original." - (interactive (list (let ((current-prefix-arg current-prefix-arg)) - (read-directory-name "Create directory: ")) - current-prefix-arg)) - (if (file-exists-p dir) - (error "Cannot make directory %s: file already exists" dir) - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that mkdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that mkdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (ange-ftp-quote-string - (if (eq (ange-ftp-host-type host) 'unix) - (ange-ftp-real-directory-file-name (nth 2 parsed)) - (ange-ftp-real-file-name-as-directory - (nth 2 parsed))))) - (abbr (ange-ftp-abbreviate-filename dir)) - (result (ange-ftp-send-cmd host user - (list 'mkdir path) - (format "Making directory %s" - abbr)))) - (or (car result) - (ange-ftp-error host user - (format "Could not make directory %s: %s" - dir - (cdr result)))) - (ange-ftp-add-file-entry dir t)) - (ange-ftp-real-make-directory dir parents))))) - -(defun ange-ftp-remove-directory (dir) - "Documented as original." - (interactive - (list (expand-file-name (read-file-name "Remove directory: " - nil nil 'confirm)))) - (if (file-directory-p dir) - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that rmdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that rmdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (ange-ftp-quote-string - (if (eq (ange-ftp-host-type host) 'unix) - (ange-ftp-real-directory-file-name - (nth 2 parsed)) - (ange-ftp-real-file-name-as-directory - (nth 2 parsed))))) - (abbr (ange-ftp-abbreviate-filename dir)) - (result (ange-ftp-send-cmd host user - (list 'rmdir path) - (format "Removing directory %s" - abbr)))) - (or (car result) - (ange-ftp-error host user - (format "Could not remove directory %s: %s" - dir - (cdr result)))) - (ange-ftp-delete-file-entry dir t)) - (ange-ftp-real-remove-directory dir))) - (error "Not a directory: %s" dir))) - -;; XEmacs change: This function isn't in the FSF version. Maybe -;; because there is no such function as diff-read-args. I can't find -;; where there ever _has_ been such a function. If you want this -;; functionality, write diff-read-args and uncomment this. - -;;(defun ange-ftp-diff (fn1 fn2 &optional switches) -;; "Documented as original." -;; (interactive (diff-read-args "Diff: " "Diff %s with: " -;; "Diff with switches: ")) -;; (or (and (stringp fn1) -;; (stringp fn2)) -;; (error "diff: arguments must be strings: %s %s" fn1 fn2)) -;; (or switches -;; (setq switches (if (stringp diff-switches) -;; diff-switches -;; (if (listp diff-switches) -;; (mapconcat 'identity diff-switches " ") -;; "")))) -;; (let* ((fn1 (expand-file-name fn1)) -;; (fn2 (expand-file-name fn2)) -;; (pa1 (ange-ftp-ftp-path fn1)) -;; (pa2 (ange-ftp-ftp-path fn2))) -;; (if (or pa1 pa2) -;; (let* ((tmp1 (and pa1 (ange-ftp-make-tmp-name (car pa1)))) -;; (tmp2 (and pa2 (ange-ftp-make-tmp-name (car pa2)))) -;; (bin1 (and pa1 (ange-ftp-binary-file fn1))) -;; (bin2 (and pa2 (ange-ftp-binary-file fn2))) -;; (dir1 (file-directory-p fn1)) -;; (dir2 (file-directory-p fn2)) -;; (old-dir default-directory) -;; (default-directory "/tmp")) ;fool FTP-smart compile.el -;; (unwind-protect -;; (progn -;; (if (and dir1 dir2) -;; (error "can't compare remote directories")) -;; (if dir1 -;; (setq fn1 (expand-file-name (file-name-nondirectory fn2) -;; fn1) -;; pa1 (ange-ftp-ftp-path fn1) -;; bin1 (ange-ftp-binary-file fn1))) -;; (if dir2 -;; (setq fn2 (expand-file-name (file-name-nondirectory fn1) -;; fn2) -;; pa2 (ange-ftp-ftp-path fn2) -;; bin2 (ange-ftp-binary-file fn2))) -;; (and pa1 (ange-ftp-copy-file-internal fn1 tmp1 t nil -;; (format "Getting %s" fn1))) -;; (and pa2 (ange-ftp-copy-file-internal fn2 tmp2 t nil -;; (format "Getting %s" fn2))) -;; (and ange-ftp-process-verbose -;; (ange-ftp-message "doing diff...")) -;; (sit-for 0) -;; (ange-ftp-real-diff (or tmp1 fn1) (or tmp2 fn2) switches) -;; (cond ((boundp 'compilation-process) -;; (while (and compilation-process -;; (eq (process-status compilation-process) -;; 'run)) -;; (accept-process-output compilation-process))) -;; ((boundp 'compilation-last-buffer) -;; (while (and compilation-last-buffer -;; (buffer-name compilation-last-buffer) -;; (get-buffer-process -;; compilation-last-buffer) -;; (eq (process-status -;; (get-buffer-process -;; compilation-last-buffer)) -;; 'run)) -;; (accept-process-output)))) -;; (and ange-ftp-process-verbose -;; (ange-ftp-message "doing diff...done")) -;; (save-excursion -;; (set-buffer (get-buffer-create "*compilation*")) -;; -;; ;; replace the default directory that we munged earlier. -;; (goto-char (point-min)) -;; (if (search-forward (concat "cd " default-directory) nil t) -;; (replace-match (concat "cd " old-dir))) -;; (setq default-directory old-dir) -;; -;; ;; massage the diff output, replacing the temporary file- -;; ;; names with their original names. -;; (if tmp1 -;; (let ((q1 (shell-quote tmp1))) -;; (goto-char (point-min)) -;; (while (search-forward q1 nil t) -;; (replace-match fn1)))) -;; (if tmp2 -;; (let ((q2 (shell-quote tmp2))) -;; (goto-char (point-min)) -;; (while (search-forward q2 nil t) -;; (replace-match fn2)))))) -;; (and tmp1 (ange-ftp-del-tmp-name tmp1)) -;; (and tmp2 (ange-ftp-del-tmp-name tmp2)))) -;; (ange-ftp-real-diff fn1 fn2 switches)))) - -(defun ange-ftp-dired-call-process (program discard &rest arguments) - "Documented as original." - ;; PROGRAM is always one of those below in the cond in dired.el. - ;; The ARGUMENTS are (nearly) always files. - (if (ange-ftp-ftp-path default-directory) - ;; Can't use ange-ftp-dired-host-type here because the current - ;; buffer is *dired-check-process output* - (condition-case oops - (cond ((equal "compress" program) - (ange-ftp-call-compress arguments)) - ((equal "uncompress" program) - (ange-ftp-call-uncompress arguments)) - ((equal "chmod" program) - (ange-ftp-call-chmod arguments)) - ;; ((equal "chgrp" program)) - ;; ((equal dired-chown-program program)) - (t (error "Unknown remote command: %s" program))) - (ftp-error (insert (format "%s: %s, %s\n" - (nth 1 oops) - (nth 2 oops) - (nth 3 oops)))) - (error (insert (format "%s\n" (nth 1 oops))))) - (apply 'call-process program nil (not discard) nil arguments))) - - -(defun ange-ftp-call-compress (args) - "Perform a compress command on a remote file. -Works by taking a copy of the file, compressing it and copying the file -back." - (if (or (not (= (length args) 2)) - (not (string-equal "-f" (car args)))) - (error - "ange-ftp-call-compress: missing -f flag and/or missing filename: %s" - args)) - (let* ((file (nth 1 args)) - (parsed (ange-ftp-ftp-path file)) - (tmp1 (ange-ftp-make-tmp-name (car parsed))) - (tmp2 (ange-ftp-make-tmp-name (car parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (nfile (ange-ftp-dired-compress-make-compressed-filename file)) - (nabbr (ange-ftp-abbreviate-filename nfile)) - (msg1 (format "Getting %s" abbr)) - (msg2 (format "Putting %s" nabbr))) - (unwind-protect - (progn - (ange-ftp-copy-file-internal file tmp1 t nil msg1) - (and ange-ftp-process-verbose - (ange-ftp-message "Compressing %s..." abbr)) - (call-process-region (point) - (point) - shell-file-name - nil - t - nil - "-c" - (format "compress -f -c < %s > %s" tmp1 tmp2)) - (and ange-ftp-process-verbose - (ange-ftp-message "Compressing %s...done" abbr)) - (if (zerop (buffer-size)) - (progn - (let (ange-ftp-process-verbose) - (delete-file file)) - (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) - (ange-ftp-del-tmp-name tmp1) - (ange-ftp-del-tmp-name tmp2)))) - -(defun ange-ftp-call-uncompress (args) - "Perform an uncompress command on a remote file. -Works by taking a copy of the file, uncompressing it and copying the file -back." - (if (not (= (length args) 1)) - (error "ange-ftp-call-uncompress: missing filename: %s" args)) - (let* ((file (car args)) - (parsed (ange-ftp-ftp-path file)) - (tmp1 (ange-ftp-make-tmp-name (car parsed))) - (tmp2 (ange-ftp-make-tmp-name (car parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (nfile (ange-ftp-dired-compress-make-compressed-filename file 'reverse)) - (nabbr (ange-ftp-abbreviate-filename nfile)) - (msg1 (format "Getting %s" abbr)) - (msg2 (format "Putting %s" nabbr)) -;; ;; Cheap hack because of problems with binary file transfers from -;; ;; VMS hosts. -;; (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed))))) - ) - (unwind-protect - (progn - (ange-ftp-copy-file-internal file tmp1 t nil msg1) - (and ange-ftp-process-verbose - (ange-ftp-message "Uncompressing %s..." abbr)) - (call-process-region (point) - (point) - shell-file-name - nil - t - nil - "-c" - (format "uncompress -c < %s > %s" tmp1 tmp2)) - (and ange-ftp-process-verbose - (ange-ftp-message "Uncompressing %s...done" abbr)) - (if (zerop (buffer-size)) - (progn - (let (ange-ftp-process-verbose) - (delete-file file)) - (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) - (ange-ftp-del-tmp-name tmp1) - (ange-ftp-del-tmp-name tmp2)))) - -(defvar ange-ftp-remote-shell "rsh" - "Remote shell to use for chmod, if FTP server rejects the `chmod' command.") - -(defun ange-ftp-call-chmod (args) - (if (< (length args) 2) - (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args)) - (let ((mode (car args))) - (mapcar - (function - (lambda (file) - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (result (ange-ftp-send-cmd host user - (list 'chmod mode path) - (format "doing chmod %s" - abbr)))) - (or (car result) - ;; if FTP server rejects chmod, try rsh chmod instead - (call-process - ange-ftp-remote-shell - nil t nil host "chmod" mode path))))))) - (cdr args))) - (setq ange-ftp-ls-cache-file nil)) ;stop confusing dired - -;; Need to abstract the way dired computes the names of compressed files. -;; I feel badly about these two overloads. - -(defun ange-ftp-dired-compress () - ;; Compress current file. Return nil for success, offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (ange-ftp-dired-compress-make-compressed-filename from-file))) - (cond ((save-excursion (beginning-of-line) - (looking-at dired-re-sym)) - (dired-log (concat "Attempt to compress a symbolic link:\n" - from-file)) - (dired-make-relative from-file)) - ((dired-check-process (concat "Compressing " from-file) - "compress" "-f" from-file) - ;; errors from the process are already logged by - ;; dired-check-process - (dired-make-relative from-file)) - (t - (dired-update-file-line to-file) - nil)))) - -(defun ange-ftp-dired-uncompress () - ;; Uncompress current file. Return nil for success, - ;; offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (ange-ftp-dired-compress-make-compressed-filename from-file 'reverse))) - (if (dired-check-process (concat "Uncompressing " from-file) - "uncompress" from-file) - (dired-make-relative from-file) - (dired-update-file-line to-file) - nil))) - -(defun ange-ftp-dired-flag-backup-files (&optional unflag-p) - "Documented as original." - (interactive "P") - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-flag-backup-files-alist))) - 'ange-ftp-real-dired-flag-backup-files) - unflag-p)) - -;;; ------------------------------------------------------------ -;;; Noddy support for async copy-file within dired. -;;; ------------------------------------------------------------ - -(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait) - "Documented as original." - (dired-handle-overwrite to) - (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil - cont nowait)) - -(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char op1 - how-to) - "Documented as original." - ;; we need to let ange-ftp-dired-create-files know that we indirectly - ;; called it rather than somebody else. - (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is - (ange-ftp-real-dired-do-create-files op-symbol file-creator operation - arg marker-char op1 how-to))) - -(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char) - "Documented as original." - (if (and (boundp 'ange-ftp-dired-do-create-files) - ;; called from ange-ftp-dired-do-create-files? - ange-ftp-dired-do-create-files - ;; any files worth copying? - fn-list - ;; we only support async copy-file at the mo. - (eq file-creator 'dired-copy-file) - ;; it is only worth calling the alternative function for remote files - ;; as we tie ourself in recursive knots otherwise. - (or (ange-ftp-ftp-path (car fn-list)) - ;; we can only call the name constructor for dired-do-create-files - ;; since the one for regexps starts prompting here, there and - ;; everywhere. - (ange-ftp-ftp-path (funcall name-constructor (car fn-list))))) - ;; use the process-filter driven routine rather than the iterative one. - (ange-ftp-dcf-1 file-creator - operation - fn-list - name-constructor - (and (boundp 'target) target) ;dynamically bound - marker-char - (current-buffer) - nil ;overwrite-query - nil ;overwrite-backup-query - nil ;failures - nil ;skipped - 0 ;success-count - (length fn-list) ;total - ) - ;; normal case... use the interative routine... much cheaper. - (ange-ftp-real-dired-create-files file-creator operation fn-list - name-constructor marker-char))) - -(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor - target marker-char buffer overwrite-query - overwrite-backup-query failures skipped - success-count total) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (if (null fn-list) - (ange-ftp-dcf-3 failures operation total skipped - success-count buffer) - - (let* ((from (car fn-list)) - (to (funcall name-constructor from))) - (if (equal to from) - (progn - (setq to nil) - (dired-log "Cannot %s to same file: %s\n" - (downcase operation) from))) - (if (not to) - (ange-ftp-dcf-1 file-creator - operation - (cdr fn-list) - name-constructor - target - marker-char - buffer - overwrite-query - overwrite-backup-query - failures - (cons (dired-make-relative from) skipped) - success-count - total) - (let* ((overwrite (file-exists-p to)) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to)))) - ;; must determine if FROM is marked before file-creator - ;; gets a chance to delete it (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) ; slow - (t nil)))) - (condition-case err - (funcall file-creator from to overwrite-confirmed - (list (function ange-ftp-dcf-2) - nil ;err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total) - t) - (file-error ; FILE-CREATOR aborted - (ange-ftp-dcf-2 nil ;result - nil ;line - err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total)))))))) - (set-buffer old-buf)))) - -(defun ange-ftp-dcf-2 (result line err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (if (or err (not result)) - (progn - (setq failures (cons (dired-make-relative from) failures)) - (dired-log "%s `%s' to `%s' failed:\n%s\n" - operation from to (or err line))) - (if overwrite - ;; If we get here, file-creator hasn't been aborted - ;; and the old entry (if any) has to be deleted - ;; before adding the new entry. - (dired-remove-file to)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (dired-add-file to actual-marker-char)) - - (ange-ftp-dcf-1 file-creator operation (cdr fn-list) - name-constructor - target - marker-char - buffer - overwrite-query - overwrite-backup-query - failures skipped success-count - total)) - (set-buffer old-buf)))) - -(defun ange-ftp-dcf-3 (failures operation total skipped success-count - buffer) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (cond - (failures - (dired-log-summary - (message "%s failed for %d of %d file%s %s" - operation (length failures) total - (dired-plural-s total) failures))) - (skipped - (dired-log-summary - (message "%s: %d of %d file%s skipped %s" - operation (length skipped) total - (dired-plural-s total) skipped))) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count)))) - (dired-move-to-filename)) - (set-buffer old-buf)))) - -;;;; ----------------------------------------------- -;;;; Unix Descriptive Listing (dl) Support -;;;; ----------------------------------------------- - -(defconst ange-ftp-dired-dl-re-dir - "^. [^ /]+/[ \n]" - "Regular expression to use to search for dl directories.") - -(or (assq 'unix:dl ange-ftp-dired-re-dir-alist) - (setq ange-ftp-dired-re-dir-alist - (cons (cons 'unix:dl ange-ftp-dired-dl-re-dir) - ange-ftp-dired-re-dir-alist))) - -(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol) - "In dired, move to the first character of the filename on this line." - ;; This is the Unix dl version. - (or eol (setq eol (progn (end-of-line) (point)))) - (let (case-fold-search) - (beginning-of-line) - (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ") - (goto-char (+ (point) 2)) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Unix dl version. - (let ((opoint (point)) - case-fold-search hidden) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion - (search-forward "\r" eol t)))) - (if hidden - (if no-error - nil - (error - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide"))) - (skip-chars-forward "^ /" eol) - (if (eq opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point))))) - -(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; File name completion support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-file-entry-active-p (sym) - "If the file entry is a symlink, returns whether the file pointed to exists. -Note that DIR is dynamically bound." - (let ((val (get sym 'val))) - (or (not (stringp val)) - (file-exists-p (ange-ftp-expand-symlink val dir))))) - -(defun ange-ftp-file-entry-not-ignored-p (sym) - "If the file entry is not a directory (nor a symlink pointing to a directory) -returns whether the file (or file pointed to by the symlink) is ignored -by completion-ignored-extensions. -Note that DIR and COMPLETION-IGNORED-PATTERN are dynamically bound." - (let ((val (get sym 'val)) - (symname (symbol-name sym))) - (if (stringp val) - (let ((file (ange-ftp-expand-symlink val dir))) - (or (file-directory-p file) - (and (file-exists-p file) - (not (string-match completion-ignored-pattern - symname))))) - (or val ; is a directory name - (not (string-match completion-ignored-pattern symname)))))) - -(defun ange-ftp-file-name-all-completions (file dir) - "Documented as original." - (setq dir (expand-file-name dir)) - (if (ange-ftp-ftp-path dir) - (progn - (ange-ftp-barf-if-not-directory dir) - (setq dir (ange-ftp-real-file-name-as-directory dir)) - (let* ((tbl (ange-ftp-get-files dir)) - (completions - (all-completions file tbl - (function ange-ftp-file-entry-active-p)))) - - ;; see whether each matching file is a directory or not... - (mapcar - (function - (lambda (file) - (let ((ent (ange-ftp-get-hash-entry file tbl))) - (if (and ent - (or (not (stringp ent)) - (file-directory-p - (ange-ftp-expand-symlink ent dir)))) - (concat file "/") - file)))) - completions))) - - (if (string-equal "/" dir) - (nconc (all-completions file (ange-ftp-generate-root-prefixes)) - (ange-ftp-real-file-name-all-completions file dir)) - (ange-ftp-real-file-name-all-completions file dir)))) - -(defun ange-ftp-file-name-completion (file dir) - "Documented as original." - (setq dir (expand-file-name dir)) - (if (ange-ftp-ftp-path dir) - (progn - (ange-ftp-barf-if-not-directory dir) - (if (equal file "") - "" - (setq dir (ange-ftp-real-file-name-as-directory dir)) ;real? - (let* ((tbl (ange-ftp-get-files dir)) - (completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - completion-ignored-extensions - "\\|"))) - (ange-ftp-save-match-data - (or (ange-ftp-file-name-completion-1 - file tbl dir (function ange-ftp-file-entry-not-ignored-p)) - (ange-ftp-file-name-completion-1 - file tbl dir (function ange-ftp-file-entry-active-p))))))) - (if (string-equal "/" dir) - (try-completion - file - (nconc (ange-ftp-generate-root-prefixes) - (mapcar 'list - (ange-ftp-real-file-name-all-completions file "/")))) - (ange-ftp-real-file-name-completion file dir)))) - - -(defun ange-ftp-file-name-completion-1 (file tbl dir predicate) - "Internal subroutine for ange-ftp-file-name-completion. Do not call this." - (let ((bestmatch (try-completion file tbl predicate))) - (if bestmatch - (if (eq bestmatch t) - (if (file-directory-p (expand-file-name file dir)) - (concat file "/") - t) - (if (and (eq (try-completion bestmatch tbl predicate) t) - (file-directory-p - (expand-file-name bestmatch dir))) - (concat bestmatch "/") - bestmatch))))) - -(defun ange-ftp-quote-filename (file) - "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" - (let ((pos 0)) - (while (setq pos (string-match "\\$" file pos)) - (setq file (concat (substring file 0 pos) - "$";; precede by escape character (also a $) - (substring file pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - file)) - -;; (defun ange-ftp-read-file-name-internal (string dir action) -;; "Documented as original." -;; (let (name realdir) -;; (if (eq action 'lambda) -;; (if (> (length string) 0) -;; (file-exists-p (substitute-in-file-name string))) -;; (if (zerop (length string)) -;; (setq name string realdir dir) -;; (setq string (substitute-in-file-name string) -;; name (file-name-nondirectory string) -;; realdir (file-name-directory string)) -;; (setq realdir (if realdir (expand-file-name realdir dir) dir))) -;; (if action -;; (file-name-all-completions name realdir) -;; (let ((specdir (file-name-directory string)) -;; (val (file-name-completion name realdir))) -;; (if (and specdir (stringp val)) -;; (ange-ftp-quote-filename (concat specdir val)) -;; val)))))) - -;; Put these lines uncommmented in your .emacs if you want C-r to refresh -;; ange-ftp's cache whilst doing filename completion. -;; -;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir) -;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir) - -(defun ange-ftp-re-read-dir (&optional dir) - "Forces a re-read of the directory DIR. If DIR is omitted then it defaults -to the directory part of the contents of the current buffer." - (interactive) - (if dir - (setq dir (expand-file-name dir)) - (setq dir (file-name-directory (expand-file-name (buffer-string))))) - (if (ange-ftp-ftp-path dir) - (progn - (setq ange-ftp-ls-cache-file nil) - (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable) - (ange-ftp-get-files dir t)))) - -;;;; ------------------------------------------------------------ -;;;; Bits and bobs to bolt ange-ftp into GNU Emacs. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-overwrite-msg - "Note: This function has been modified to work with ange-ftp.") - -(defun ange-ftp-safe-documentation (fun) - "A documentation function that isn't quite as fragile." - (condition-case () - (documentation fun) - (error nil))) - -(defun ange-ftp-overwrite-fn (fun) - "Replace FUN's function definition with ange-ftp-FUN's, saving the -original definition as ange-ftp-real-FUN. The original documentation is -placed on the new definition suitably augmented." - (let* ((name (symbol-name fun)) - (saved (intern (concat "ange-ftp-real-" name))) - (new (intern (concat "ange-ftp-" name))) - (nfun (symbol-function new)) - (exec-directory (if (or (equal (nth 3 command-line-args) "dump") - (equal (nth 4 command-line-args) "dump")) - "../etc/" - exec-directory))) - - ;; *** This is unnecessary for any ange-ftp function (I think): - (while (symbolp nfun) - (setq nfun (symbol-function nfun))) - - ;; Interpose the ange-ftp function between the function symbol and the - ;; original definition of the function symbol AT TIME OF FIRST LOAD. - ;; We must only redefine the symbol-function of FUN the very first - ;; time, to avoid blowing away stuff that overloads FUN after this. - - ;; We direct the function symbol to the ange-ftp's function symbol - ;; rather than function definition to allow reloading of this file or - ;; redefining of the individual function (e.g., during debugging) - ;; later after some other code has been loaded on top of our stuff. - - (or (fboundp saved) - (progn - (fset saved (symbol-function fun)) - (fset fun new))) - - ;; Rewrite the doc string on the new ange-ftp function. This should - ;; be done every time the file is loaded (or a function is redefined), - ;; because the underlying overloaded function may have changed its doc - ;; string. - - (let* ((doc-str (ange-ftp-safe-documentation saved)) - (ndoc-str (concat doc-str (and doc-str "\n") - ange-ftp-overwrite-msg))) - - (cond ((listp nfun) - ;; Probe to test whether function is in preloaded read-only - ;; memory, and if so make writable copy: - (condition-case nil - (setcar nfun (car nfun)) - (error - (setq nfun (copy-sequence nfun)) ; shallow copy only - (fset new nfun))) - (let ((ndoc-cdr (nthcdr 2 nfun))) - (if (stringp (car ndoc-cdr)) - ;; Replace the existing docstring. - (setcar ndoc-cdr ndoc-str) - ;; There is no docstring. Insert the overwrite msg. - (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) - (setcar ndoc-cdr ange-ftp-overwrite-msg)))) - (t - ;; it's an emacs19 compiled-code object - (if (not (fboundp 'compiled-function-arglist)) - ;; the old way (typical emacs lack of abstraction) - (let ((new-code (append nfun nil))) ; turn it into a list - (if (nthcdr 4 new-code) - (setcar (nthcdr 4 new-code) ndoc-str) - (setcdr (nthcdr 3 new-code) (cons ndoc-str nil))) - (fset new (apply 'make-byte-code new-code))) - ;; the new way (marginally less random) for XEmacs 19.8+ - (fset new - (apply 'make-byte-code - (compiled-function-arglist nfun) - (compiled-function-instructions nfun) - (compiled-function-constants nfun) - (compiled-function-stack-depth nfun) - ndoc-str - (if (commandp nfun) - (list (nth 1 (compiled-function-interactive - nfun))) - nil))) - )))))) - -(defun ange-ftp-overwrite-dired () - (if (not (fboundp 'dired-ls)) ;dired should have been loaded by now - (ange-ftp-overwrite-fn 'dired-readin) ; classic dired - (ange-ftp-overwrite-fn 'make-directory) ; tree dired and v19 stuff - (ange-ftp-overwrite-fn 'remove-directory) - ;; XEmacs - not anymore because ange-ftp-diff is hosed - ;; (ange-ftp-overwrite-fn 'diff) - (ange-ftp-overwrite-fn 'dired-run-shell-command) - (ange-ftp-overwrite-fn 'dired-ls) - (ange-ftp-overwrite-fn 'dired-call-process) - ;; Can't use (fset 'ange-ftp-dired-readin 'ange-ftp-tree-dired-readin) - ;; here because it confuses ange-ftp-overwrite-fn. - (fset 'ange-ftp-dired-readin (symbol-function 'ange-ftp-tree-dired-readin)) - (ange-ftp-overwrite-fn 'dired-readin) - (ange-ftp-overwrite-fn 'dired-insert-headerline) - (ange-ftp-overwrite-fn 'dired-move-to-filename) - (ange-ftp-overwrite-fn 'dired-move-to-end-of-filename) - (ange-ftp-overwrite-fn 'dired-get-filename) - (ange-ftp-overwrite-fn 'dired-between-files) - (ange-ftp-overwrite-fn 'dired-clean-directory) - (ange-ftp-overwrite-fn 'dired-flag-backup-files) - (ange-ftp-overwrite-fn 'dired-backup-diff) - (if (fboundp 'dired-do-create-files) - ;; dired 6.0 or later. - (progn - (ange-ftp-overwrite-fn 'dired-copy-file) - (ange-ftp-overwrite-fn 'dired-create-files) - (ange-ftp-overwrite-fn 'dired-do-create-files))) - (if (fboundp 'dired-compress-make-compressed-filename) - ;; it's V5.255 or later - (ange-ftp-overwrite-fn 'dired-compress-make-compressed-filename) - ;; ange-ftp-overwrite-fn confuses dired-mark-map here. - (fset 'ange-ftp-real-dired-compress (symbol-function 'dired-compress)) - (fset 'dired-compress 'ange-ftp-dired-compress) - (fset 'ange-ftp-real-dired-uncompress (symbol-function 'dired-uncompress)) - (fset 'dired-uncompress 'ange-ftp-dired-uncompress))) - - (ange-ftp-overwrite-fn 'dired-find-file) - (ange-ftp-overwrite-fn 'dired-revert)) - -;; Attention! -;; It would be nice if ange-ftp-add-hook was generalized to -;; (defun ange-ftp-add-hook (hook-var hook-function &optional postpend), -;; where the optional postpend variable stipulates that hook-function -;; should be post-pended to the hook-var, rather than prepended. -;; Then, maybe we should overwrite dired with -;; (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired t). -;; This is because dired-load-hook is commonly used to add the dired extras -;; features (dired-x.el, dired-trns.el, dired-nstd.el, ...). Some of these -;; extras features overwrite functions in dired.el with fancier versions. -;; The "extras" overwrites would then clobber the ange-ftp overwrites. -;; As long as the ange-ftp overwrites are carefully written to use -;; ange-ftp-real-... when the directory is local, then doing the ange-ftp -;; overwrites after the extras overwites should be OK. -;; At the moment, I think that there aren't any conflicts between the extras -;; overwrites, and the ange-ftp overwrites. This may not last though. - -(defun ange-ftp-add-hook (hook-var hook-function) - "Prepend hook-function to hook-var's value, if it is not already an element. -hook-var's value may be a single function or a list of functions." - (if (boundp hook-var) - (let ((value (symbol-value hook-var))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (and (not (memq hook-function value)) - (set hook-var - (if value (cons hook-function value) hook-function))) - (and (not (eq hook-function value)) - (set hook-var - (list hook-function value))))) - (set hook-var hook-function))) - -;; To load ange-ftp and not dired (leaving it to autoload), define -;; dired-load-hook and make sure dired.el ends with: -;; (run-hooks 'dired-load-hook) -;; -(if (and (boundp 'dired-load-hook) - (not (featurep 'dired))) - (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired) - (require 'dired) - (ange-ftp-overwrite-dired)) - -;; In case v19 or emacs-19.el already loaded: -;; (Can't use fboundp to check if emacs-19.el is -;; loaded, because these functions are probably -;; bound to autoloads.) - -(if (and (fboundp 'make-directory) - (not (and (listp (symbol-function 'make-directory)) - (eq (car (symbol-function 'make-directory)) 'autoload)))) - (ange-ftp-overwrite-fn 'make-directory)) -(if (and (fboundp 'remove-directory) - (not (and (listp (symbol-function 'remove-directory)) - (eq (car (symbol-function 'remove-directory)) 'autoload)))) - (ange-ftp-overwrite-fn 'remove-directory)) -;; XEmacs change -- ange-ftp-diff is hosed -;;(if (and (fboundp 'diff) -;; (not (and (listp (symbol-function 'diff)) -;; (eq (car (symbol-function 'diff)) 'autoload)))) -;; (ange-ftp-overwrite-fn 'diff)) - -(ange-ftp-overwrite-fn 'insert-file-contents) -(ange-ftp-overwrite-fn 'directory-files) -(ange-ftp-overwrite-fn 'file-directory-p) -(ange-ftp-overwrite-fn 'file-writable-p) -(ange-ftp-overwrite-fn 'file-readable-p) -(ange-ftp-overwrite-fn 'file-symlink-p) -(ange-ftp-overwrite-fn 'delete-file) -;; (ange-ftp-overwrite-fn 'read-file-name-internal) -(ange-ftp-overwrite-fn 'verify-visited-file-modtime) -(ange-ftp-overwrite-fn 'file-exists-p) -(ange-ftp-overwrite-fn 'write-region) -(ange-ftp-overwrite-fn 'backup-buffer) -(ange-ftp-overwrite-fn 'copy-file) -(ange-ftp-overwrite-fn 'rename-file) -(ange-ftp-overwrite-fn 'file-attributes) -(ange-ftp-overwrite-fn 'file-name-directory) -(ange-ftp-overwrite-fn 'file-name-nondirectory) -(ange-ftp-overwrite-fn 'file-name-as-directory) -(ange-ftp-overwrite-fn 'directory-file-name) -(ange-ftp-overwrite-fn 'expand-file-name) -(ange-ftp-overwrite-fn 'file-name-all-completions) -(ange-ftp-overwrite-fn 'file-name-completion) - -(or (memq 'ange-ftp-set-buffer-mode find-file-hooks) - (setq find-file-hooks - (cons 'ange-ftp-set-buffer-mode find-file-hooks))) - - -;;;; ------------------------------------------------------------ -;;;; VOS support (VOS support is probably broken, -;;;; but I don't know anything about VOS.) -;;;; ------------------------------------------------------------ -; -;(defun ange-ftp-fix-path-for-vos (path &optional reverse) -; (setq path (copy-sequence path)) -; (let ((from (if reverse ?\> ?\/)) -; (to (if reverse ?\/ ?\>)) -; (i (1- (length path)))) -; (while (>= i 0) -; (if (= (aref path i) from) -; (aset path i to)) -; (setq i (1- i))) -; path)) -; -;(or (assq 'vos ange-ftp-fix-path-func-alist) -; (setq ange-ftp-fix-path-func-alist -; (cons '(vos . ange-ftp-fix-path-for-vos) -; ange-ftp-fix-path-func-alist))) -; -;(or (memq 'vos ange-ftp-dumb-host-types) -; (setq ange-ftp-dumb-host-types -; (cons 'vos ange-ftp-dumb-host-types))) -; -;(defun ange-ftp-fix-dir-path-for-vos (dir-path) -; (ange-ftp-fix-path-for-vos -; (concat dir-path -; (if (eq ?/ (aref dir-path (1- (length dir-path)))) -; "" "/") -; "*"))) -; -;(or (assq 'vos ange-ftp-fix-dir-path-func-alist) -; (setq ange-ftp-fix-dir-path-func-alist -; (cons '(vos . ange-ftp-fix-dir-path-for-vos) -; ange-ftp-fix-dir-path-func-alist))) -; -;(defvar ange-ftp-vos-host-regexp nil -; "If a host matches this regexp then it is assumed to be running VOS.") -; -;(defun ange-ftp-vos-host (host) -; (and ange-ftp-vos-host-regexp -; (ange-ftp-save-match-data -; (string-match ange-ftp-vos-host-regexp host)))) -; -;(defun ange-ftp-parse-vos-listing () -; "Parse the current buffer which is assumed to be in VOS list -all -;format, and return a hashtable as the result." -; (let ((tbl (ange-ftp-make-hashtable)) -; (type-list -; '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40) -; ("^Dirs: [0-9]+\n+" t 30))) -; type-regexp type-is-dir type-col file) -; (goto-char (point-min)) -; (ange-ftp-save-match-data -; (while type-list -; (setq type-regexp (car (car type-list)) -; type-is-dir (nth 1 (car type-list)) -; type-col (nth 2 (car type-list)) -; type-list (cdr type-list)) -; (if (re-search-forward type-regexp nil t) -; (while (eq (char-after (point)) ? ) -; (move-to-column type-col) -; (setq file (buffer-substring (point) -; (progn -; (end-of-line 1) -; (point)))) -; (ange-ftp-put-hash-entry file type-is-dir tbl) -; (forward-line 1)))) -; (ange-ftp-put-hash-entry "." 'vosdir tbl) -; (ange-ftp-put-hash-entry ".." 'vosdir tbl)) -; tbl)) -; -;(or (assq 'vos ange-ftp-parse-list-func-alist) -; (setq ange-ftp-parse-list-func-alist -; (cons '(vos . ange-ftp-parse-vos-listing) -; ange-ftp-parse-list-func-alist))) - -;;;; ------------------------------------------------------------ -;;;; VMS support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-fix-path-for-vms (path &optional reverse) - "Convert PATH from UNIX-ish to VMS. If REVERSE given then convert from VMS -to UNIX-ish." - (ange-ftp-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" path) - (let (drive dir file) - (if (match-beginning 1) - (setq drive (substring path - (match-beginning 1) - (match-end 1)))) - (if (match-beginning 2) - (setq dir - (substring path (match-beginning 2) (match-end 2)))) - (if (match-beginning 3) - (setq file - (substring path (match-beginning 3) (match-end 3)))) - (and dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - (substring dir 1 -1))))) - (concat (and drive - (concat "/" drive "/")) - dir (and dir "/") - file)) - (error "path %s didn't match" path)) - (let (drive dir file tmp) - (if (string-match "^/[^:]+:/" path) - (setq drive (substring path 1 - (1- (match-end 0))) - path (substring path (match-end 0)))) - (setq tmp (file-name-directory path)) - (if tmp - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1))))) - (setq file (file-name-nondirectory path)) - (concat drive - (and dir (concat "[" (if drive nil ".") dir "]")) - file))))) - -;; (ange-ftp-fix-path-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1") -;; (ange-ftp-fix-path-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t) - -(or (assq 'vms ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(vms . ange-ftp-fix-path-for-vms) - ange-ftp-fix-path-func-alist))) - -(or (memq 'vms ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'vms ange-ftp-dumb-host-types))) - -;; It is important that this function barf for directories for which we know -;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". -;; This is because it saves an unnecessary FTP error, or possibly the listing -;; might succeed, but give erroneous info. This last case is particularly -;; likely for OS's (like MTS) for which we need to use a wildcard in order -;; to list a directory. - -(defun ange-ftp-fix-dir-path-for-vms (dir-path) - "Convert path from UNIX-ish to VMS ready for a DIRectory listing." - ;; Should there be entries for .. -> [-] and . -> [] below. Don't - ;; think so, because expand-filename should have already short-circuited - ;; them. - (cond ((string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) - (error "Cannot get listing for device.")) - ((ange-ftp-fix-path-for-vms dir-path)))) - -(or (assq 'vms ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(vms . ange-ftp-fix-dir-path-for-vms) - ange-ftp-fix-dir-path-func-alist))) - -(defvar ange-ftp-vms-host-regexp nil) - -(defun ange-ftp-vms-host (host) - "Return whether HOST is running VMS." - (and ange-ftp-vms-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-vms-host-regexp host)))) - -;; Because some VMS ftp servers convert filenames to lower case -;; we allow a-z in the filename regexp. I'm not too happy about this. - -(defconst ange-ftp-vms-filename-regexp - (concat - "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][_A-Za-z0-9$---]*\\)\\." - "[_A-Za-z0-9$---]*;+[0-9]*\\)") - "Regular expression to match for a valid VMS file name in Dired buffer. -Stupid freaking bug! Position of _ and $ shouldn't matter but they do. -Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX -Other orders of $ and _ seem to all work just fine.") - -;; These parsing functions are as general as possible because the syntax -;; of ftp listings from VMS hosts is a bit erratic. What saves us is that -;; the VMS filename syntax is so rigid. If they bomb on a listing in the -;; standard VMS Multinet format, then this is a bug. If they bomb on a listing -;; from vms.weird.net, then too bad. - -(defun ange-ftp-parse-vms-filename () - "Extract the next filename from a VMS dired-like listing." - (if (re-search-forward - ange-ftp-vms-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0)))) - -(defun ange-ftp-parse-vms-listing () - "Parse the current buffer which is assumed to be in MultiNet FTP dir -format, and return a hashtable as the result." - (let ((tbl (ange-ftp-make-hashtable)) - file) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while (setq file (ange-ftp-parse-vms-filename)) - (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) - ;; deal with directories - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) t tbl) - (ange-ftp-put-hash-entry file nil tbl) - (if (string-match ";[0-9]+$" file) ; deal with extension - ;; sans extension - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) nil tbl))) - (forward-line 1)) - ;; Would like to look for a "Total" line, or a "Directory" line to - ;; make sure that the listing isn't complete garbage before putting - ;; in "." and "..", but we can't even count on all VAX's giving us - ;; either of these. - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl)) - tbl)) - -(or (assq 'vms ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(vms . ange-ftp-parse-vms-listing) - ange-ftp-parse-list-func-alist))) - -;; This version only deletes file entries which have -;; explicit version numbers, because that is all VMS allows. - -;; Can the following two functions be speeded up using file -;; completion functions? - -(defun ange-ftp-vms-delete-file-entry (path &optional dir-p) - (if dir-p - (ange-ftp-internal-delete-file-entry path t) - (ange-ftp-save-match-data - (let ((file (ange-ftp-get-file-part path))) - (if (string-match ";[0-9]+$" file) - ;; In VMS you can't delete a file without an explicit - ;; version number, or wild-card (e.g. FOO;*) - ;; For now, we give up on wildcards. - (let ((files (ange-ftp-get-hash-entry - (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (let* ((root (substring file 0 - (match-beginning 0))) - (regexp (concat "^" - (regexp-quote root) - ";[0-9]+$")) - versions) - (ange-ftp-del-hash-entry file files) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (mapatoms - '(lambda (sym) - (and (string-match regexp (get sym 'key)) - (setq versions t))) - files) - (or versions - (ange-ftp-del-hash-entry root files)))))))))) - -(or (assq 'vms ange-ftp-delete-file-entry-alist) - (setq ange-ftp-delete-file-entry-alist - (cons '(vms . ange-ftp-vms-delete-file-entry) - ange-ftp-delete-file-entry-alist))) - -(defun ange-ftp-vms-add-file-entry (path &optional dir-p) - (if dir-p - (ange-ftp-internal-add-file-entry path t) - (let ((files (ange-ftp-get-hash-entry - (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (let ((file (ange-ftp-get-file-part path))) - (ange-ftp-save-match-data - (if (string-match ";[0-9]+$" file) - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) - nil files) - ;; Need to figure out what version of the file - ;; is being added. - (let ((regexp (concat "^" - (regexp-quote file) - ";\\([0-9]+\\)$")) - (version 0)) - (mapatoms - '(lambda (sym) - (let ((name (get sym 'key))) - (and (string-match regexp name) - (setq version - (max version - (string-to-int - (substring name - (match-beginning 1) - (match-end 1)))))))) - files) - (setq version (1+ version)) - (ange-ftp-put-hash-entry - (concat file ";" (int-to-string version)) - nil files)))) - (ange-ftp-put-hash-entry file nil files)))))) - -(or (assq 'vms ange-ftp-add-file-entry-alist) - (setq ange-ftp-add-file-entry-alist - (cons '(vms . ange-ftp-vms-add-file-entry) - ange-ftp-add-file-entry-alist))) - - -(defun ange-ftp-add-vms-host (host) - "Interactively adds a given HOST to ange-ftp-vms-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-vms-host host)) - (setq ange-ftp-vms-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-vms-host-regexp "\\|") - ange-ftp-vms-host-regexp) - ange-ftp-host-cache nil))) - - -(defun ange-ftp-vms-file-name-as-directory (name) - (ange-ftp-save-match-data - (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (ange-ftp-real-file-name-as-directory name))) - -(or (assq 'vms ange-ftp-file-name-as-directory-alist) - (setq ange-ftp-file-name-as-directory-alist - (cons '(vms . ange-ftp-vms-file-name-as-directory) - ange-ftp-file-name-as-directory-alist))) - -;;; Tree dired support: - -;; For this code I have borrowed liberally from Sebastian Kremer's -;; dired-vms.el - - -;; These regexps must be anchored to beginning of line. -;; Beware that the ftpd may put the device in front of the filename. - -(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]" - "Regular expression to use to search for VMS executable files.") - -(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]" - "Regular expression to use to search for VMS directories.") - -(or (assq 'vms ange-ftp-dired-re-exe-alist) - (setq ange-ftp-dired-re-exe-alist - (cons (cons 'vms ange-ftp-dired-vms-re-exe) - ange-ftp-dired-re-exe-alist))) - -(or (assq 'vms ange-ftp-dired-re-dir-alist) - (setq ange-ftp-dired-re-dir-alist - (cons (cons 'vms ange-ftp-dired-vms-re-dir) - ange-ftp-dired-re-dir-alist))) - -(defun ange-ftp-dired-vms-insert-headerline (dir) - ;; VMS inserts a headerline. I would prefer the headerline - ;; to be in ange-ftp format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ wildcard ") - (forward-line 1)) - (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n") - (delete-region (point) (match-end 0)))) - (ange-ftp-real-dired-insert-headerline dir)) - -(or (assq 'vms ange-ftp-dired-insert-headerline-alist) - (setq ange-ftp-dired-insert-headerline-alist - (cons '(vms . ange-ftp-dired-vms-insert-headerline) - ange-ftp-dired-insert-headerline-alist))) - -(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the VMS version. - (let (case-fold-search) - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward ange-ftp-vms-filename-regexp eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'vms ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(vms . ange-ftp-dired-vms-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let (opoint hidden case-fold-search) - (setq opoint (point)) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (re-search-forward ange-ftp-vms-filename-regexp eol t)) - (or no-error - (not (eq opoint (point))) - (error - (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -(defun ange-ftp-dired-vms-between-files () - (save-excursion - (beginning-of-line) - (or (equal (following-char) 10) ; newline - (equal (following-char) 9) ; tab - (progn (forward-char 2) - (or (looking-at "Total of") - (equal (following-char) 32)))))) - -(or (assq 'vms ange-ftp-dired-between-files-alist) - (setq ange-ftp-dired-between-files-alist - (cons '(vms . ange-ftp-dired-vms-between-files) - ange-ftp-dired-between-files-alist))) - -;; Beware! In VMS filenames must be of the form "FILE.TYPE". -;; Therefore, we cannot just append a ".Z" to filenames for -;; compressed files. Instead, we turn "FILE.TYPE" into -;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. - -(defun ange-ftp-vms-make-compressed-filename (name &optional reverse) - (if reverse - (cond - ((string-match "-Z;[0-9]+$" name) - (substring name 0 (match-beginning 0))) - ((string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0))) - ((string-match "-Z$" name) - (substring name 0 -2)) - (t name)) - (if (string-match ";[0-9]+$" name) - (concat (substring name 0 (match-beginning 0)) - "-Z") - (concat name "-Z")))) - -(or (assq 'vms ange-ftp-dired-compress-make-compressed-filename-alist) - (setq ange-ftp-dired-compress-make-compressed-filename-alist - (cons '(vms . ange-ftp-vms-make-compressed-filename) - ange-ftp-dired-compress-make-compressed-filename-alist))) - -;; When the filename is too long, VMS will use two lines to list a file -;; (damn them!) This will confuse dired. To solve this, need to convince -;; Sebastian to use a function dired-go-to-end-of-file-line, instead of -;; (forward-line 1). This would require a number of changes to dired.el. -;; If dired gets confused, revert-buffer will fix it. - -(defun ange-ftp-dired-vms-ls-trim () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward ange-ftp-vms-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - - -(or (assq 'vms ange-ftp-dired-ls-trim-alist) - (setq ange-ftp-dired-ls-trim-alist - (cons '(vms . ange-ftp-dired-vms-ls-trim) - ange-ftp-dired-ls-trim-alist))) - -(defun ange-ftp-vms-bob-version (name) - (ange-ftp-save-match-data - (if (string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(or (assq 'vms ange-ftp-bob-version-alist) - (setq ange-ftp-bob-version-alist - (cons '(vms . ange-ftp-vms-bob-version) - ange-ftp-bob-version-alist))) - -;;; The vms version of clean-directory has 2 more optional args -;;; than the usual dired version. This is so that it can be used by -;;; ange-ftp-dired-vms-flag-backup-files. - -(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." -; (interactive "P") ; Never actually called interactively. - (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions))) - (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - ;; late-retention must NEVER be allowed to be less than 1 in VMS! - ;; This could wipe ALL copies of the file. - (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep))) - (action (or msg "Cleaning")) - (trample-marker (or marker dired-del-marker)) - (file-version-assoc-list ())) - (message (concat action - " numerical backups (keeping %d late, %d old)...") - late-retention early-retention) - ;; Look at each file. - ;; If the file has numeric backup versions, - ;; put on file-version-assoc-list an element of the form - ;; (FILENAME . VERSION-NUMBER-LIST) - (dired-map-dired-file-lines (function - ange-ftp-dired-vms-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions not to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines - (function - ange-ftp-dired-vms-trample-file-versions mark)) - (message (concat action " numerical backups...done")))) - -(or (assq 'vms ange-ftp-dired-clean-directory-alist) - (setq ange-ftp-dired-clean-directory-alist - (cons '(vms . ange-ftp-dired-vms-clean-directory) - ange-ftp-dired-clean-directory-alist))) - -(defun ange-ftp-dired-vms-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." -(let ((path (nth 2 (ange-ftp-ftp-path fn)))) - (if (string-match ";[0-9]+$" path) - (let* ((path (substring path 0 (match-beginning 0))) - (fn (ange-ftp-replace-path-component fn path))) - (if (not (assq fn file-version-assoc-list)) - (let* ((base-versions - (concat (file-name-nondirectory path) ";")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar - '(lambda (arg) - (if (and (string-match - "[0-9]+$" arg bv-length) - (= (match-beginning 0) bv-length)) - (string-to-int (substring arg bv-length)) - 0)) - possibilities))) - (if versions - (setq - file-version-assoc-list - (cons (cons fn versions) - file-version-assoc-list))))))))) - -(defun ange-ftp-dired-vms-trample-file-versions (fn) - (let* ((start-vn (string-match ";[0-9]+$" fn)) - base-version-list) - (and start-vn - (setq base-version-list ; there was a base version to which - (assoc (substring fn 0 start-vn) ; this looks like a - file-version-assoc-list)) ; subversion - (not (memq (string-to-int (substring fn (1+ start-vn))) - base-version-list)) ; this one doesn't make the cut - (progn (beginning-of-line) - (delete-char 1) - (insert trample-marker))))) - -(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p) - (let ((dired-kept-versions 1) - (kept-old-versions 0) - marker msg) - (if unflag-p - (setq marker ?\040 msg "Unflagging") - (setq marker dired-del-marker msg "Cleaning")) - (ange-ftp-dired-vms-clean-directory nil marker msg))) - -(or (assq 'vms ange-ftp-dired-flag-backup-files-alist) - (setq ange-ftp-dired-flag-backup-files-alist - (cons '(vms . ange-ftp-dired-vms-flag-backup-files) - ange-ftp-dired-flag-backup-files-alist))) - -(defun ange-ftp-dired-vms-backup-diff (&optional switches) - (let ((file (dired-get-filename 'no-dir)) - bak) - (if (and (string-match ";[0-9]+$" file) - ;; Find most recent previous version. - (let ((root (substring file 0 (match-beginning 0))) - (ver - (string-to-int (substring file (1+ (match-beginning 0))))) - found) - (setq ver (1- ver)) - (while (and (> ver 0) (not found)) - (setq bak (concat root ";" (int-to-string ver))) - (and (file-exists-p bak) (setq found t)) - (setq ver (1- ver))) - found)) - (if switches - (diff (expand-file-name bak) (expand-file-name file) switches) - (diff (expand-file-name bak) (expand-file-name file))) - (error "No previous version found for %s" file)))) - -(or (assq 'vms ange-ftp-dired-backup-diff-alist) - (setq ange-ftp-dired-backup-diff-alist - (cons '(vms . ange-ftp-dired-vms-backup-diff) - ange-ftp-dired-backup-diff-alist))) - - -;;;; ------------------------------------------------------------ -;;;; MTS support -;;;; ------------------------------------------------------------ - - -(defun ange-ftp-fix-path-for-mts (path &optional reverse) - "Convert PATH from UNIX-ish to MTS. If REVERSE given then convert from -MTS to UNIX-ish." - (ange-ftp-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) - (let (acct file) - (if (match-beginning 1) - (setq acct (substring path 0 (match-end 1)))) - (if (match-beginning 2) - (setq file (substring path - (match-beginning 2) (match-end 2)))) - (concat (and acct (concat "/" acct "/")) - file)) - (error "path %s didn't match" path)) - (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) - (concat (substring path 1 (match-end 1)) - (substring path (match-beginning 2) (match-end 2))) - ;; Let's hope that mts will recognize it anyway. - path)))) - -(or (assq 'mts ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(mts . ange-ftp-fix-path-for-mts) - ange-ftp-fix-path-func-alist))) - -(defun ange-ftp-fix-dir-path-for-mts (dir-path) - "Convert path from UNIX-ish to MTS ready for a DIRectory listing. -Remember that there are no directories in MTS." - (if (string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.") - (let ((dir-path (ange-ftp-fix-path-for-mts dir-path))) - (cond - ((string-equal dir-path "") - "?") - ((string-match ":$" dir-path) - (concat dir-path "?")) - (dir-path))))) ; It's just a single file. - -(or (assq 'mts ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(mts . ange-ftp-fix-dir-path-for-mts) - ange-ftp-fix-dir-path-func-alist))) - -(or (memq 'mts ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'mts ange-ftp-dumb-host-types))) - -(defvar ange-ftp-mts-host-regexp nil) - -(defun ange-ftp-mts-host (host) - "Return whether HOST is running MTS." - (and ange-ftp-mts-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-mts-host-regexp host)))) - -(defun ange-ftp-parse-mts-listing () - "Parse the current buffer which is assumed to be in -mts ftp dir format." - (let ((tbl (ange-ftp-make-hashtable))) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while (re-search-forward ange-ftp-date-regexp nil t) - (end-of-line) - (skip-chars-backward " ") - (let ((end (point))) - (skip-chars-backward "-A-Z0-9_.!") - (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl)) - (forward-line 1))) - ;; Don't need to bother with .. - (ange-ftp-put-hash-entry "." t tbl) - tbl)) - -(or (assq 'mts ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(mts . ange-ftp-parse-mts-listing) - ange-ftp-parse-list-func-alist))) - -(defun ange-ftp-add-mts-host (host) - "Interactively adds a given HOST to ange-ftp-mts-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-mts-host host)) - (setq ange-ftp-mts-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-mts-host-regexp "\\|") - ange-ftp-mts-host-regexp) - ange-ftp-host-cache nil))) - -;;; Tree dired support: - -;; There aren't too many systems left that use MTS. This dired support will -;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems -;; implement ftp in the same way. If not, it might be necessary to make the -;; following more flexible. - -(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the MTS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward - ange-ftp-date-regexp eol t) - (progn - (skip-chars-forward " ") ; Eat blanks after date - (skip-chars-forward "0-9:" eol) ; Eat time or year - (skip-chars-forward " " eol) ; one space before filename - ;; When listing an account other than the users own account it appends - ;; ACCT: to the beginning of the filename. Skip over this. - (and (looking-at "[A-Z0-9_.]+:") - (goto-char (match-end 0))) - (point)) - (if raise-error - (error "No file on this line") - nil))) - -(or (assq 'mts ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(mts . ange-ftp-dired-mts-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MTS version. - (let (opoint hidden case-fold-search) - (setq opoint (point) - eol (save-excursion (end-of-line) (point)) - hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (skip-chars-forward "-A-Z0-9._!" eol)) - (or no-error - (not (eq opoint (point))) - (error - (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; CMS support -;;;; ------------------------------------------------------------ - -;; Since CMS doesn't have any full pathname syntax, we have to fudge -;; things with cd's. We actually send too many cd's, but is dangerous -;; to try to remember the current minidisk, because if the connection -;; is closed and needs to be reopened, we will find ourselves back in -;; the default minidisk. This is fairly likely since CMS ftp servers -;; usually close the connection after 5 minutes of inactivity. - -;; Have I got the filename character set right? - -(defun ange-ftp-fix-path-for-cms (path &optional reverse) - "Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert -from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, -so we fudge things by sending cd's." - (ange-ftp-save-match-data - (if reverse - ;; Since we only convert output from a pwd in this direction, - ;; we'll assume that it's a minidisk, and make it into a - ;; directory file name. Note that the expand-dir-hashtable - ;; stores directories without the trailing /. Is this - ;; consistent? - (concat "/" path) - (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" - path) - (let ((minidisk (substring path 1 (match-end 1)))) - (if (match-beginning 2) - (let ((file (substring path (match-beginning 2) - (match-end 2))) - (cmd (concat "cd " minidisk)) - - ;; Note that host and user are bound in the call - ;; to ange-ftp-send-cmd - (proc (ange-ftp-get-process host user))) - - ;; Must use ange-ftp-raw-send-cmd here to avoid - ;; an infinite loop. - (if (car (ange-ftp-raw-send-cmd proc cmd msg)) - file - ;; failed... try ONCE more. - (setq proc (ange-ftp-get-process host user)) - (let ((result (ange-ftp-raw-send-cmd proc cmd msg))) - (if (car result) - file - ;; failed. give up. - (ange-ftp-error host user - (format "cd to minidisk %s failed: %s" - minidisk (cdr result))))))) - ;; return the minidisk - minidisk)) - (error "Invalid CMS filename"))))) - -(or (assq 'cms ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(cms . ange-ftp-fix-path-for-cms) - ange-ftp-fix-path-func-alist))) - -(or (memq 'cms ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'cms ange-ftp-dumb-host-types))) - -(defun ange-ftp-fix-dir-path-for-cms (dir-path) - "Convert path from UNIX-ish to VMS ready for a DIRectory listing." - (cond - ((string-equal "/" dir-path) - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-path) - (let* ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) - ;; host and user are bound in the call to ange-ftp-send-cmd - (proc (ange-ftp-get-process host user)) - (cmd (concat "cd " minidisk)) - (file (if (match-beginning 2) - ;; it's a single file - (substring path (match-beginning 2) - (match-end 2)) - ;; use the wild-card - "*"))) - (if (car (ange-ftp-raw-send-cmd proc cmd)) - file - ;; try again... - (setq proc (ange-ftp-get-process host user)) - (let ((result (ange-ftp-raw-send-cmd proc cmd))) - (if (car result) - file - ;; give up - (ange-ftp-error host user - (format "cd to minidisk %s failed: " - minidisk (cdr result)))))))) - (t (error "Invalid CMS pathname")))) - -(or (assq 'cms ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(cms . ange-ftp-fix-dir-path-for-cms) - ange-ftp-fix-dir-path-func-alist))) - -(defvar ange-ftp-cms-host-regexp nil - "Regular expression to match hosts running the CMS operating system.") - -(defun ange-ftp-cms-host (host) - "Return whether the host is running CMS." - (and ange-ftp-cms-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-cms-host-regexp host)))) - -(defun ange-ftp-add-cms-host (host) - "Interactively adds a given HOST to ange-ftp-cms-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-cms-host host)) - (setq ange-ftp-cms-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-cms-host-regexp "\\|") - ange-ftp-cms-host-regexp) - ange-ftp-host-cache nil))) - -(defun ange-ftp-parse-cms-listing () - "Parse the current buffer which is assumed to be a CMS directory listing." - ;; If we succeed in getting a listing, then we will assume that the minidisk - ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work - ;; because ange-ftp doesn't know that the root hashtable has only part of - ;; the info. It will assume that if a minidisk isn't in it, then it doesn't - ;; exist. It would be nice if completion worked for minidisks, as we - ;; discover them. -; (let* ((dir-file (directory-file-name file)) -; (root (file-name-directory dir-file)) -; (minidisk (ange-ftp-get-file-part dir-file)) -; (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable))) -; (if root-tbl -; (ange-ftp-put-hash-entry minidisk t root-tbl) -; (setq root-tbl (ange-ftp-make-hashtable)) -; (ange-ftp-put-hash-entry minidisk t root-tbl) -; (ange-ftp-put-hash-entry "." t root-tbl) -; (ange-ftp-set-files root root-tbl))) - ;; Now do the usual parsing - (let ((tbl (ange-ftp-make-hashtable))) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while - (re-search-forward - "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t) - (ange-ftp-put-hash-entry - (concat (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - nil tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl)) - tbl)) - -(or (assq 'cms ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(cms . ange-ftp-parse-cms-listing) - ange-ftp-parse-list-func-alist))) - -;;; Tree dired support: - -(defconst ange-ftp-dired-cms-re-exe - "^. [-A-Z0-9$_]+ +EXEC " - "Regular expression to use to search for CMS executables.") - -(or (assq 'cms ange-ftp-dired-re-exe-alist) - (setq ange-ftp-dired-re-exe-alist - (cons (cons 'cms ange-ftp-dired-cms-re-exe) - ange-ftp-dired-re-exe-alist))) - - -(defun ange-ftp-dired-cms-insert-headerline (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (ange-ftp-real-dired-insert-headerline dir)) - -(or (assq 'cms ange-ftp-dired-insert-headerline-alist) - (setq ange-ftp-dired-insert-headerline-alist - (cons '(cms . ange-ftp-dired-cms-insert-headerline) - ange-ftp-dired-insert-headerline-alist))) - -(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol) - "In dired, move to the first char of filename on this line." - ;; This is the CMS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (let (case-fold-search) - (beginning-of-line) - (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t) - (goto-char (1+ (match-beginning 0))) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'cms ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(cms . ange-ftp-dired-cms-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (let ((opoint (point)) - case-fold-search hidden) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion - (search-forward "\r" eol t)))) - (if hidden - (if no-error - nil - (error - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide"))) - (skip-chars-forward "-A-Z0-9$_" eol) - (skip-chars-forward " " eol) - (skip-chars-forward "-A-Z0-9$_" eol) - (if (eq opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point))))) - -(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -(defun ange-ftp-cms-make-compressed-filename (name &optional reverse) - (if reverse - (if (string-match "-Z$" name) - (substring name 0 -2) - name) - (concat name "-Z"))) - -(or (assq 'cms ange-ftp-dired-compress-make-compressed-filename-alist) - (setq ange-ftp-dired-compress-make-compressed-filename-alist - (cons '(cms . ange-ftp-cms-make-compressed-filename) - ange-ftp-dired-compress-make-compressed-filename-alist))) - -(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep) - (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep))) - (and name - (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name) - (concat (substring name 0 (match-end 1)) - "." - (substring name (match-beginning 2) (match-end 2))) - name)))) - -(or (assq 'cms ange-ftp-dired-get-filename-alist) - (setq ange-ftp-dired-get-filename-alist - (cons '(cms . ange-ftp-dired-cms-get-filename) - ange-ftp-dired-get-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; Finally provide package. -;;;; ------------------------------------------------------------ - -;; This is so that VC doesn't need to be hacked up. I think the fsf way is -;; a bit cleaner. (Forgive me, as I have sinned...) The great side-effect -;; of this change is that ange-ftp will now autoload...even w/o being fully -;; converted to use the filename-handler-alist. --Stig - -;; Turn off RCS/SCCS processing to save time. -;; This returns nil for any file name as argument. -(put 'vc-registered 'ange-ftp 'null) -^L -;;; Define ways of getting at unmodified Emacs primitives, -;;; turning off our handler. - -(defun ange-ftp-run-real-handler (operation args) - (let ((inhibit-file-name-handlers - (cons 'ange-ftp-hook-function - (cons 'ange-ftp-completion-hook-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers)))) - (inhibit-file-name-operation operation)) - (apply operation args))) - -;;;###autoload -(defun ange-ftp-hook-function (operation &rest args) - (let ((fn (get operation 'ange-ftp))) - (if fn (apply fn args) - (ange-ftp-run-real-handler operation args)))) - -;;;###autoload -(or (assoc (car ange-ftp-path-format) file-name-handler-alist) - (setq file-name-handler-alist - (cons (cons (car ange-ftp-path-format) 'ange-ftp-hook-function) - file-name-handler-alist))) - -;; ;;; This regexp recognizes and absolute filenames with only one component, -;; ;;; for the sake of hostname completion. -;; ;;;###autoload -;; (or (assoc "^/[^/:]*\\'" file-name-handler-alist) -;; (setq file-name-handler-alist -;; (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function) -;; file-name-handler-alist))) - -(provide 'ange-ftp) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-cd.el --- a/lisp/dired/dired-cd.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -;;; -*- Mode: Emacs-lisp -*- ;;; -;;; dired-cd.el - Adjust Working Directory for Tree Dired Shell Commands -;;; Id: dired-cd.el,v 1.14 1991/11/01 14:28:27 sk RelBeta -;;; Copyright (C) 1991 Hugh Secker-Walker -;;; -;;; Author: Hugh Secker-Walker hugh@ear-ache.mit.edu -;;; -;;; Modified by Sebastian Kremer -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-cd|Hugh Secker-Walker|hugh@ear-ache.mit.edu -;; |Adjust Working Directory for Tree Dired Shell Commands -;; |Date: 1991/11/01 14:28:27 |Revision: 1.14 | - -;;; SUMMARY - -;;; This extension to Sebastian Kremer's (sk@thp.Uni-Koeln.DE) Tree-Dired -;;; permits the working directory of the dired shell commands -;;; dired-do-shell-command and dired-do-background-shell-command -;;; to be the files' subdirectory under certain circumstances. -;;; Loading this extension does not change the behavior of dired until -;;; the variables dired-cd-same-subdir and/or dired-cd-on-each are -;;; non-nil. - - -;;; FUNCTIONALITY PROVIDED - -;;; If dired-cd-same-subdir is non-nil and if all the selected files -;;; (marked, non-zero numeric ARG, etc.) are in the same directory, then -;;; dired-do-shell-command and dired-do-background-shell-command will -;;; cause the shell to perform a cd into that directory before the -;;; commands are executed. Also, the selected filenames will be provided -;;; to the command without any directory components. - -;;; If dired-cd-on-each is non-nil and if the on-each option is specified -;;; (numeric arg of zero), then dired-do-shell-command and -;;; dired-do-background-shell-command will perform a cd into the -;;; directory of each file before the commands on that file are executed. -;;; Also, each filename will be provided to the command without any -;;; directory components. Note that this on-each behavior occurs -;;; regardless of whether the files are all in the same directory or not. - -;;; After the above "cd wrapping" has occured, the existing -;;; dired-shell-stuff-it is used to do file-name substitution and -;;; quoting, so custom versions of this procedure should work, e.g. -;;; dired-trans will transform commands correctly. However, since -;;; filenames lack any directory components, features that use the -;;; directory components will fail, e.g. the dired-trans [d] transform -;;; specifier will be empty. - -;;; New variables (user options): -;;; dired-cd-same-subdir -;;; dired-cd-on-each -;;; -;;; Replaces procedures: -;;; dired-do-shell-command (new doc and prompt, calls dired-cd-wrap-it) -;;; -;;; Adds procedures: -;;; dired-cd-wrap-it (wraps calls to dired-shell-stuff-it with "cd ") -;;; dired-files-same-directory - - -;; INSTALLATION -;; -;; Put this file into your load-path and add (load "dired-cd") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-cd"))) -;; -;; Do (setq dired-cd-same-subdir t) and perhaps (setq dired-cd-on-each t) -;; in your .emacs. By default, dired-cd doesn't change the behavior of -;; dired when it is loaded. -;; -;; If dired-cd-same-subdir is non-nil, then the shell commands cd to -;; the appropriate directory if all the selected files (marked, -;; numeric ARG, etc.) are in that directory; however, on-each behavior -;; is not changed. -;; -;; If dired-cd-on-each is non-nil, then each instance of the command -;; for an on-each shell command runs in the file's directory -;; regardless of whether the files are all in the same directory. - - -(defvar dired-cd-same-subdir nil - "*If non-nil, and selected file(s) (by marks, numeric arg, \\[universal-argument]) are in same -subdir, causes dired shell command to run in that subdir. Filenames provided -to shell commands are stripped of their directory components. Does not -affect behavior of on-each, for that see variable dired-cd-on-each.") - -(defvar dired-cd-on-each nil - "*If non-nil, on-each causes each dired shell command to run in the -file's directory. Filenames provided to shell commands are stripped of -their directory components. Also see variable dired-cd-same-subdir.") - -;; Redefines dired.el's version. -;; Changes to documentation and prompt, and uses dired-cd-wrap-it. -(defun dired-do-shell-command (&optional arg in-background) - "Run a shell command on the marked files. -If there is output, it goes to a separate buffer. -The list of marked files is appended to the command string unless asterisks - `*' indicate the place(s) where the list should go. -If no files are marked or a specific numeric prefix arg is given, uses - next ARG files. With a zero argument, run command on each marked file - separately: `cmd * foo' results in `cmd F1 foo; ...; cmd Fn foo'. - As always, a raw arg (\\[universal-argument]) means the current file. -The option variables dired-cd-same-subdir and dired-cd-on-each - permit the command\(s\) to run in the files' directories if appropriate, - and thus determine where output files are created. Default is top - directory. The prompt mentions the file(s) or the marker, the cd subdir, - and the on-each flags when they apply. -No automatic redisplay is attempted, as the file names may have - changed. Type \\[dired-do-redisplay] to redisplay the marked files." - ;; Function dired-shell-stuff-it (called by dired-cd-wrap-it) does the - ;; actual file-name substitution and can be redefined for customization. - (interactive "P") - (let* ((on-each (equal arg 0)) - (file-list (dired-mark-get-files t (if on-each nil arg))) - (prompt (concat (if in-background "& " "! ") - (if (or (and on-each dired-cd-on-each) - (and dired-cd-same-subdir - (not on-each) - (dired-files-same-directory file-list))) - "cd ; " "") - "on " - (if on-each "each " "") - "%s: ")) - ;; Give feedback on file(s) and working directory status - (command (dired-read-shell-command - prompt (if on-each nil arg) file-list)) - (result (dired-cd-wrap-it command file-list on-each arg))) - ;; execute the shell command - (dired-run-shell-command result in-background))) - -(defun dired-cd-wrap-it (command files on-each &optional raw) - "Args COMMAND FILES ON-EACH &optional RAW-ARG, like dired-shell-stuff-it. -Calls dired-shell-stuff-it, but wraps the resulting command\(s\) -with \"cd \" commands when appropriate. Note: when ON-EACH is non-nil, -dired-shell-stuff-it is called once for each file in FILES. -See documentation of variables dired-cd-same-subdir and dired-cd-on-each -for wrap conditions." - (if on-each;; command applied to each file separately - ;; cd's are done in subshells since all shells I know of have subshells - (let* ((cwd "");; current working directory - (in-subshell nil) - (cmd (mapconcat;; files over command, fuss with "cd " - (function - (lambda (file) - (let ((cd "") d);; cd command and file's directory - (if (not dired-cd-on-each) nil;; poor man's (when ...) - (setq d;; directory, relative to default-directory - (directory-file-name - (or (file-name-directory file) "")) - file (file-name-nondirectory file)) - (if (not (string= d cwd));; new subdir, new subshell - (setq cwd d - ;; close existing subshell, - ;; open a new one - cd (concat (if in-subshell "); " "") - "(cd " (shell-quote cwd) "; ") - in-subshell t)) - ) - ;; existing dired-shell-stuff-it does - ;; actual command substitution - (concat cd (dired-shell-stuff-it command (list file) - on-each raw))))) - files "; "))) - (if in-subshell (concat cmd ")") cmd));; close an open subshell - - ;; not on-each, all files are args to single command instance - (let ((same-dir (and dired-cd-same-subdir - (dired-files-same-directory files nil))) - (cd "")) - ;; Let the prepended cd command be relative to default-directory, - ;; and only give it if necessary. This way, after ange-ftp - ;; prepends its own cd command, it will still work. - ;; sk 3-Sep-1991 14:23 - ;; hsw 31-Oct-1991 -- filenames relative to default-directory - (if (and same-dir (not (equal same-dir ""))) - (setq files (mapcar (function file-name-nondirectory) files) - cd (concat "cd " (shell-quote same-dir) "; "))) - ;; existing dired-shell-stuff-it does the command substitution - (concat cd (dired-shell-stuff-it command files on-each raw))))) - -(defun dired-files-same-directory (file-list &optional absolute) - "If all files in LIST are in the same directory return it, otherwise nil. -Returned name has no trailing slash. \"Same\" means file-name-directory of -the files are string=. File names in LIST must all be absolute or all be -relative. Implicitly, relative file names are in default-directory. If -optional ABS is non-nil, the returned name will be absolute, otherwise the -returned name will be absolute or relative as per the files in LIST." - (let ((dir (file-name-directory (car file-list)))) - (if (memq nil (mapcar (function - (lambda (file) - (string= dir (file-name-directory file)))) - file-list)) - nil - (directory-file-name - (if (or (not absolute) (and dir (file-name-absolute-p dir))) - (or dir "") - (concat default-directory dir)))))) - -(provide 'dired-cd) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-chmod.el --- a/lisp/dired/dired-chmod.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -;;; dired-chmod.el - interactive editing of file permissions in Dired listings. - -;;; Copyright (C) 1995 Russell Ritchie, - -;; Keywords: dired extensions, faces, interactive chmod - -;; 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 -;; 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. - -;; 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. - -;;; To turn this on do: -;;; (require 'dired-chmod) -;;; (add-hook 'dired-after-readin-hook 'dired-permissions-highlight) - -(require 'dired) ; - -(defvar dired-permissions-regexp "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]" - "Regexp matching the file permissions part of a dired line.") - -(defvar dired-pre-permissions-regexp "^. [0-9 ]*[-d]" - "Regexp matching the preamble to file permissions part of a dired line. -This shouldn't match socket or symbolic link lines (which aren't editable).") - -(or (find-face 'dired-face-permissions) - (and - (make-face 'dired-face-permissions) - (set-face-foreground 'dired-face-permissions '(color . "mediumorchid") - nil nil 'append) - (set-face-underline-p 'dired-face-permissions '((mono . t) - (grayscale . t)) nil - nil 'append))) - -(defun dired-activate-extent (extent keys fn) - (let ((keymap (make-sparse-keymap))) - (while keys - (define-key keymap (car keys) fn) - (setq keys (cdr keys))) - (set-extent-face extent 'dired-face-permissions) - (set-extent-property extent 'keymap keymap) - (set-extent-property extent 'highlight t) - (set-extent-property - extent 'help-echo - "Type rsStwx to set file permissions to taste interactively."))) - -(defun dired-chmod-do-chmod (state) - (let* ((file (dired-get-filename)) - (operation (concat "chmod" " " state " " file)) - (failure (apply (function dired-check-process) - operation "chmod" state (list file))) - (here (point))) - (dired-do-redisplay) - (goto-char (+ here 1)) - (dired-make-permissions-interactive) - (if failure - (dired-log-summary - (message "%s: error - type W to see why." operation))))) - -(defun dired-u-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "u+r") - (dired-chmod-do-chmod "u-r"))) - -(defun dired-u-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "u+w") - (dired-chmod-do-chmod "u-w"))) - -(defun dired-u-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "u+s")) - ((equal key ?S) (dired-chmod-do-chmod "u+S")) - ((equal key ?x) (dired-chmod-do-chmod "u+x")) - (t (dired-chmod-do-chmod (cond ((looking-at "s") "u-s") - ((looking-at "S") "u-S") - ((looking-at "x") "u-x") - (t "u-x"))))))) - -(defun dired-g-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "g+r") - (dired-chmod-do-chmod "g-r"))) - -(defun dired-g-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "g+w") - (dired-chmod-do-chmod "g-w"))) - -(defun dired-g-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "g+s")) - ((equal key ?x) (dired-chmod-do-chmod "g+x")) - (t (dired-chmod-do-chmod (if (looking-at "s") "g-s" "g-x")))))) - -(defun dired-o-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "o+r") - (dired-chmod-do-chmod "o-r"))) - -(defun dired-o-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "o+w") - (dired-chmod-do-chmod "o-w"))) - -(defun dired-o-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "o+s")) - ((equal key ?t) (dired-chmod-do-chmod "o+t")) - ((equal key ?x) (dired-chmod-do-chmod "o+x")) - (t (dired-chmod-do-chmod (cond ((looking-at "s") "o-s") - ((looking-at "t") "o-t") - ((looking-at "x") "o-x") - (t "o-x"))))))) - -;;;###autoload -(defun dired-make-permissions-interactive () - (save-excursion - (beginning-of-line 0) - (if (and (re-search-forward dired-pre-permissions-regexp (end-of-line) t) - (looking-at dired-permissions-regexp)) - (let* ((start (point)) - (u-r-extent (make-extent start (+ start 1))) - (u-w-extent (make-extent (+ start 1) (+ start 2))) - (u-x-extent (make-extent (+ start 2) (+ start 3))) - (g-r-extent (make-extent (+ start 3) (+ start 4))) - (g-w-extent (make-extent (+ start 4) (+ start 5))) - (g-x-extent (make-extent (+ start 5) (+ start 6))) - (o-r-extent (make-extent (+ start 6) (+ start 7))) - (o-w-extent (make-extent (+ start 7) (+ start 8))) - (o-x-extent (make-extent (+ start 8) (+ start 9)))) - (dired-activate-extent u-r-extent '(r space) 'dired-u-r) - (dired-activate-extent u-w-extent '(w space) 'dired-u-w) - (dired-activate-extent u-x-extent '(s S x space) 'dired-u-x) - (dired-activate-extent g-r-extent '(r space) 'dired-g-r) - (dired-activate-extent g-w-extent '(w space) 'dired-g-w) - (dired-activate-extent g-x-extent '(s x space) 'dired-g-x) - (dired-activate-extent o-r-extent '(r space) 'dired-o-r) - (dired-activate-extent o-w-extent '(w space) 'dired-o-w) - (dired-activate-extent o-x-extent '(s t x space) 'dired-o-x))))) - -(defun dired-permissions-highlight () - (message "Highlighting permissions...") - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (eolp)) - (dired-make-permissions-interactive)) - (forward-line 1)) - (message "Highlighting permissions...done"))) - -(provide 'dired-chmod) - -;; dired-chmod.el ends here. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-cwd.el --- a/lisp/dired/dired-cwd.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -;;;; dired-cwd.el - Fix a command's current working directory in Tree Dired. - -(defconst dired-cwd-version (substring "!Revision: 1.2 !" 11 -2) - "!Id: dired-cwd.el,v 1.2 1991/10/08 15:31:28 sk RelBeta !") - -;; Copyright (C) 1991 by Sebastian Kremer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-cwd|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Fix a command's current working directory in Tree Dired. -;; |Date: 1991/10/08 15:31:28 |Revision: 1.2 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-cwd-make-magic "dired-cwd") -;; -;; You have to load dired-x.el in your dired-load-hook to define -;; function default-directory, or you will not benefit from this -;; package: as long as function default-directory is not defined, the -;; functions wrapped by dired-cwd-make-magic will behave as before. - -;; EXAMPLE USAGE ====================================================== -;; -;; How to fix M-x compile (and grep) to know about Tree Dired's multiple -;; working directories by putting the following lines into your ~/.emacs: -;; -;; (require 'compile) -;; (dired-cwd-make-magic 'compile1) -;; -;; After that, a compilation or grep started in a subdirectory in a -;; Dired buffer will have that subdirectory as working directory. -;; -;; Note you must require 'compile as function compile1 is redefined. -;; You could use a load hook instead by adding the line -;; -;; (run-hooks 'compile-load-hook) -;; -;; at the end of compile.el and setting -;; -;; (setq compile-load-hook '(lambda () (dired-cwd-make-magic 'compile1))) -;; -;; in your ~/.emacs. - - -;;;###autoload -(defun dired-cwd-make-magic (function) - "Modify COMMAND so that it's working directory is the current dired directory. -This works by binding `default-directory' to `(default-directory)'s value. -See also function `default-directory'." - (interactive "aMake work with tree dired (function): ") - (if (commandp function) - (error "Cannot make interactive functions work for tree dired")) - (let ((save-name (intern (concat "dired-cwd-wrap-real-" (symbol-name - function)))) - new-function) - (setq new-function - (` (lambda (&rest dired-cwd-args) - ;; Name our formal args unique to avoid shadowing - ;; through dynamic scope. - (let ((default-directory - (if (fboundp 'default-directory) - ;; This is defined in dired-x.el, but dired - ;; may not yet be loaded. - (default-directory) - default-directory))) - (apply 'funcall (quote (, save-name)) dired-cwd-args))))) - (or (fboundp save-name) - (fset save-name (symbol-function function))) - (fset function new-function))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-guess.el --- a/lisp/dired/dired-guess.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;;; -*- Mode: Emacs-lisp -*- ;;; -;;; dired-guess.el - In Dired, guess what shell command to apply. - -;;; Copyright (C) 1991, 1992 Gregory N. Shapiro -;;; -;;; Author: Gregory N. Shapiro gshapiro@wpi.wpi.edu -;;; -;;; 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; This extension to Sebastian Kremer's (sk@thp.Uni-Koeln.DE) Tree-Dired -;;; permits dired to guess a shell command to use when the user performs -;;; a shell command on a single file. -;;; -;;; New variables (user options): -;;; dired-auto-shell-command-alist -;;; dired-auto-shell-use-last-extension -;;; dired-guess-have-gnutar -;;; -;;; Replaces procedures: -;;; dired-read-shell-command (new doc, calls dired-guess-shell-command) -;;; -;;; Adds procedures: -;;; dired-guess-shell-command (guesses command by comparing file extensions -;;; to dired-auto-shell-command-alist) - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-guess|Gregory N. Shapiro|gshapiro@wpi.wpi.edu -;; |Guess a Dired shell command from the filename. - -;; INSTALLATION -;; -;; Put this file into your load-path and add (load "dired-guess") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-guess"))) -;; -;; Note: dired-guess must be loaded after dired-extra. -;; -;; If dired-auto-shell-use-last-extension is nil, all file extensions will -;; be used to determine the command to use. If nil, use all the -;; extensions. For example, foo.tar.Z would guess for the .tar.Z extension. -;; If non-nil, uses only the last extension of the filename. For example, -;; foo.tar.Z would use the guess for the .Z extension. -;; -;; Set dired-guess-have-gnutar to the name of the GNU tar file (defaults to -;; "gnutar"). Set to nil if you don't have GNU tar installed on your system. -;; GNU tar is available for anonymous ftp at prep.ai.mit.edu. - -(defvar dired-guess-have-gnutar "gnutar" - "*If non-nil, name of GNU tar (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe is then used.") - -(defvar dired-guess-tar (or dired-guess-have-gnutar "tar")) - -(defvar dired-auto-shell-command-alist - (list - '(".Z" . "uncompress") - '(".Z.uu" . "uudecode * | uncompress") - '(".uu" . "uudecode") - '(".hqx" . "mcvert") - '(".sh" . "sh") - '(".shar" . "unshar") - (cons ".tar" (concat dired-guess-tar " xvf")) - (cons ".tar.Z" (if dired-guess-have-gnutar - (concat dired-guess-tar " xvfz") - (concat "zcat * | " dired-guess-tar " xvf -"))) - (cons ".tar.Z.uu" (if dired-guess-have-gnutar - (concat "uudecode * | " dired-guess-tar " xvfz -") - "uudecode * | zcat | tar xvf -"))) - - "*Alist of file extensions and their suggested commands. -See also variable `dired-auto-shell-use-last-extension'.") - -(defvar dired-auto-shell-use-last-extension nil - "*If non-nil, uses only the last extension of the filename. - For example, foo.tar.Z would use the guess for the .Z extension. -If nil, use all the extensions. For example, foo.tar.Z would guess - for the .tar.Z extension.") - -(defun dired-read-shell-command (prompt arg files) - "Read a dired shell command using generic minibuffer history. -This command tries to guess a command from the filename(s) -from the variable `dired-auto-shell-command-alist' (which see)." - (dired-mark-pop-up - nil 'shell files ; bufname type files - 'dired-guess-shell-command ; function &rest args - (format prompt (dired-mark-prompt arg files)) files)) - - -(defun dired-guess-shell-command (prompt files) - ;;"Ask user with PROMPT for a shell command, guessing a default from FILES." - (let ((defalt (if (cdr files) - nil ; If more than one file, don't guess - (cdr (assoc - (substring (car files) ; Separate extension & lookup - (if dired-auto-shell-use-last-extension - (string-match "\.[^.]*$" (car files)) - (string-match "\\." (car files)))) - dired-auto-shell-command-alist))))) - (if (not (featurep 'gmhist)) - (read-string prompt defalt) - (if defalt - (put 'dired-shell-command-history 'default defalt))) - (read-with-history-in 'dired-shell-command-history prompt))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-link.el --- a/lisp/dired/dired-link.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,135 +0,0 @@ -;;!emacs -;; -;; FILE: dired-link.el -;; SUMMARY: Properly resolves UNIX (and Apollo variant) links under dired. -;; Works for both classic dired (V18) and tree dired (V19). -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 09-May-89 -;; LAST-MOD: 30-Aug-92 at 19:15:57 by Bob Weiner -;; -;; Copyright (C) 1989, 1991, 1992, Free Software Foundation, Inc. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; This file is part of InfoDock. -;; -;; DESCRIPTION: -;; -;; This library is used in conjunction with the Emacs dired facility. -;; To install it, simply load this file or create a -;; dired hook which loads this file. Then use {M-x dired RTN} -;; or {C-x C-f RTN} as one normally would. -;; -;; The changes below to 'dired-noselect' assume UNIX shell file -;; abbreviation and UNIX file name conventions. -;; -;; This modified version of the 'dired-noselect' function automatically -;; resolves all recursive links properly and edits the final directory that -;; a link points to, called the link referent. It handles Apollo-isms such -;; as /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin -> -;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles -;; relative links properly as in /usr/local/emacs -> gnu/emacs which must -;; be resolved relative to the '/usr/local' directory. -;; -;; DESCRIP-END. - -;; ************************************************************************ -;; Internal functions -;; ************************************************************************ - -;; Normally, if one performs a dired multiple times on a directory which is a -;; link, a new buffer will be created each time. This is due to the fact -;; that 'dired-find-buffer' is called in 'dired-noselect' before the link is -;; resolved. The following code solves this problem by checking for a -;; previously existing buffer that is performing dired on the directory that -;; the link resolves to. This is also done recursively. If one is found, -;; the dired buffer that shows the link is killed and the previously existing -;; one is used and re-read in. - -(defun dired-link-noselect-classic (dirname) - "Like M-x dired but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - (setq dirname (dired-link-referent (directory-file-name dirname))) - (if (equal dirname "") - nil - (if (= (aref dirname 0) ?~) (setq dirname (expand-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (let ((buffer (dired-find-buffer dirname))) - (set-buffer buffer) - (dired-readin dirname buffer) - (dired-move-to-filename) - (dired-mode dirname) - buffer))) - -(defun dired-link-noselect-tree (dirname &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name - (dired-link-referent (directory-file-name dirname)))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (dired-internal-noselect dirname switches)) - -;; Overload as appropriate for Classic (V18) or Tree Dired -(fset 'dired-noselect (if (fboundp 'dired-internal-noselect) - 'dired-link-noselect-tree - 'dired-link-noselect-classic)) - -;; -;; Resolves all UNIX links. -;; Works with Apollo's variant and other strange links. Will fail on -;; Apollos if the '../' notation is used to move just above the '/' -;; directory level. This is fairly uncommon and so the problem has not been -;; fixed. -;;; -(defun dired-link-referent (linkname) - "Returns expanded file or directory referent of LINKNAME. -LINKNAME should not end with a directory delimiter. -If LINKNAME is not a string, returns nil. -If LINKNAME is not a link, it is simply expanded and returned." - (if (not (stringp linkname)) - nil - (let ((referent)) - (while (setq referent (file-symlink-p linkname)) - (setq linkname (dired-link-expand - referent (file-name-directory linkname))))) - (dired-link-expand linkname (file-name-directory linkname)))) - -(defun dired-link-expand (referent dirname) - "Expands REFERENT relative to DIRNAME and returns." - (let ((var-link) - (dir dirname)) - (while (string-match "\\$(\\([^\)]*\\))" referent) - (setq var-link (getenv (substring referent (match-beginning 1) - (match-end 1))) - referent (concat (substring referent 0 (match-beginning 0)) - var-link - (substring referent (match-end 0))))) - ;; If referent is not an absolute path - (let ((nd-abbrev (string-match "`node_data" referent))) - (if (and nd-abbrev (= nd-abbrev 0)) - (setq referent (concat - ;; Prepend node name given in dirname, if any - (and (string-match "^//[^/]+" dirname) - (substring dirname 0 (match-end 0))) - "/sys/" (substring referent 1))))) - (while (string-match "\\.\\." referent) - ;; Match to "//.." or "/.." at the start of link referent - (while (string-match "^\\(//\\.\\.\\|/\\.\\.\\)\\(/\\|$\\)" referent) - (setq referent (substring referent (match-end 1)))) - ;; Match to "../" or ".." at the start of link referent - (while (string-match "^\\.\\.\\(/\\|$\\)" referent) - (setq dir (file-name-directory (directory-file-name dir)) - referent (concat dir (substring referent (match-end 0))))) - ;; Match to rest of "../" in link referent - (while (string-match "[^/]+/\\.\\./" referent) - (setq referent (concat (substring referent 0 (match-beginning 0)) - (substring referent (match-end 0)))))) - (and (/= (aref referent 0) ?~) - (/= (aref referent 0) ?/) - (setq referent (concat dirname referent)))) - referent) - -(provide 'dired-link) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-lisp.el --- a/lisp/dired/dired-lisp.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -;;;; dired-lisp.el - emulate Tree Dired's ls completely in Emacs Lisp - -;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM! - -(defconst dired-lisp-version (substring "!Revision: 1.8 !" 11 -2) - "!Id: dired-lisp.el,v 1.8 1992/05/01 17:50:56 sk Exp !") - -;; Copyright (C) 1992 by Sebastian Kremer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-lisp|Sebastian Kremer|sk@thp.uni-koeln.de -;; |emulate Tree Dired's ls completely in Emacs Lisp -;; |Date: 1992/05/01 17:50:56 |Revision: 1.8 | - -;; INSTALLATION ======================================================= -;; -;; Put this file into your load-path. Loading it will result in -;; redefining function dired-ls to not call ls. - -;; You need tree dired from ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z, -;; classic (e.g. 18.57) dired.el will not work. - -;; OVERVIEW =========================================================== - -;; This file overloads tree dired so that all fileinfo is retrieved -;; directly from Emacs lisp, without using an ls subprocess. - -;; Useful if you cannot afford to fork Emacs on a real memory UNIX, -;; under VMS, or if you don't have the ls program, or if you want -;; different format from what ls offers. - -;; Beware that if you change the output format of dired-ls, you'll -;; have to change dired-move-to-filename and -;; dired-move-to-end-of-filename as well. - -;; With this package is loaded, dired uses regexps instead of shell -;; wildcards. If you enter regexps remember to double each $ sign. -;; For example, to dired all elisp (*.el) files, enter `.*\.el$$', -;; resulting in the regexp `.*\.el$'. - -;; WARNING =========================================================== - -;; With earlier version of this program I sometimes got an internal -;; Emacs error: - -;; Signalling: (wrong-type-argument natnump #) - -;; The datatype differs (I also got #o67 once). - -;; Sometimes emacs just crashed with a fatal error. - -;; After I've avoided using directory-files and file-attributes -;; together inside a mapcar, the bug didn't surface any longer. - -;; RESTRICTIONS ===================================================== - -;; * many ls switches are ignored, see docstring of `dired-ls'. - -;; * In Emacs 18: cannot display date of file, displays a fake date -;; "Jan 00 00:00" instead (dates do work in Emacs 19) - -;; * Only numeric uid/gid - -;; * if you load dired-lisp after ange-ftp, remote listings look -;; really strange: -;; -;; total 1 -;; d????????? -1 -1 -1 -1 Jan 1 1970 . -;; d????????? -1 -1 -1 -1 Jan 1 1970 .. -;; -;; This is because ange-ftp's file-attributes does not return much -;; useful information. -;; -;; If you load dired-lisp first, there seem to be no problems. - -;; TODO ============================================================== - -;; Recognize some more ls switches: R F - - -(require 'dired) ; we will redefine dired-ls: -(or (fboundp 'dired-lisp-unix-ls) - (fset 'dired-lisp-unix-ls (symbol-function 'dired-ls))) - -(fset 'dired-ls 'dired-lisp-ls) - -(defun dired-lisp-ls (file &optional switches wildcard full-directory-p) - "dired-lisp.el's version of dired-ls. -Known switches: A a S r i s t -In Emacs 19, additional known switches are: c u -Others are ignored. - - Insert ls output of FILE, optionally formatted with SWITCHES. -Optional third arg WILDCARD means treat non-directory part of FILE as -emacs regexp (_not_ a shell wildcard). If you enter regexps remember -to double each $ sign. - -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d'. - -SWITCHES default to dired-listing-switches." - (or switches (setq switches dired-listing-switches)) - (or (consp switches) ; convert to list of chars - (setq switches (mapcar 'identity switches))) - (if wildcard - (setq wildcard (file-name-nondirectory file) ; actually emacs regexp - ;; perhaps convert it from shell to emacs syntax? - file (file-name-directory file))) - (if (or wildcard - full-directory-p) - (let* ((dir (file-name-as-directory file)) - (default-directory dir);; so that file-attributes works - (sum 0) - elt - (file-list (directory-files dir nil wildcard)) - file-alist - ;; do all bindings here for speed - fil attr) - (cond ((memq ?A switches) - (setq file-list - (dired-lisp-delete-matching "^\\.\\.?$" file-list))) - ((not (memq ?a switches)) - ;; if neither -A nor -a, flush . files - (setq file-list - (dired-lisp-delete-matching "^\\." file-list)))) - (setq file-alist - (mapcar - (function - (lambda (x) - ;; file-attributes("~bogus") bombs - (cons x (file-attributes (expand-file-name x))))) - ;; inserting the call to directory-files right here - ;; seems to stimulate an Emacs bug - ;; ILLEGAL DATATYPE (#o37777777727) or #o67 - file-list)) - (insert "total \007\n") ; filled in afterwards - (setq file-alist - (dired-lisp-handle-switches file-alist switches)) - (while file-alist - (setq elt (car file-alist) - short (car elt) - attr (cdr elt) - file-alist (cdr file-alist) - fil (concat dir short) - sum (+ sum (nth 7 attr))) - (insert (dired-lisp-format short attr switches))) - ;; Fill in total size of all files: - (save-excursion - (search-backward "total \007") - (goto-char (match-end 0)) - (delete-char -1) - (insert (format "%d" (1+ (/ sum 1024)))))) - ;; if not full-directory-p, FILE *must not* end in /, as - ;; file-attributes will not recognize a symlink to a directory - ;; must make it a relative filename as ls does: - (setq file (file-name-nondirectory file)) - (insert (dired-lisp-format file (file-attributes file) switches)))) - -(defun dired-lisp-delete-matching (regexp list) - ;; Delete all elements matching REGEXP from LIST, return new list. - ;; Should perhaps use setcdr for efficiency. - (let (result) - (while list - (or (string-match regexp (car list)) - (setq result (cons (car list) result))) - (setq list (cdr list))) - result)) - -(defun dired-lisp-handle-switches (file-alist switches) - ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES). - ;; Return new alist sorted according to SWITCHES which is a list of - ;; characters. Default sorting is alphabetically. - (let (index) - (setq file-alist - (sort file-alist - (cond ((memq ?S switches) ; sorted on size - (function - (lambda (x y) - ;; 7th file attribute is file size - ;; Make largest file come first - (< (nth 7 (cdr y)) - (nth 7 (cdr x)))))) - ((memq ?t switches) ; sorted on time - (setq index (dired-lisp-time-index switches)) - (function - (lambda (x y) - (time-lessp (nth index (cdr y)) - (nth index (cdr x)))))) - (t ; sorted alphabetically - (function - (lambda (x y) - (string-lessp (car x) - (car y))))))))) - (if (memq ?r switches) ; reverse sort order - (setq file-alist (nreverse file-alist))) - file-alist) - -;; From Roland McGrath. Can use this to sort on time. -(defun time-lessp (time0 time1) - (let ((hi0 (car time0)) - (hi1 (car time1)) - (lo0 (car (cdr time0))) - (lo1 (car (cdr time1)))) - (or (< hi0 hi1) - (and (= hi0 hi1) - (< lo0 lo1))))) - - -(defun dired-lisp-format (file-name file-attr &optional switches) - (let ((file-type (nth 0 file-attr))) - (concat (if (memq ?i switches) ; inode number - (format "%6d " (nth 10 file-attr))) - ;; nil is treated like "" in concat - (if (memq ?s switches) ; size in K - (format "%4d " (1+ (/ (nth 7 file-attr) 1024)))) - (nth 8 file-attr) ; permission bits - ;; numeric uid/gid are more confusing than helpful - ;; Emacs should be able to make strings of them. - ;; user-login-name and user-full-name could take an - ;; optional arg. - (format " %3d %-8d %-8d %8d " - (nth 1 file-attr) ; no. of links - (nth 2 file-attr) ; uid - (nth 3 file-attr) ; gid - (nth 7 file-attr) ; size in bytes - ) - (dired-lisp-format-time file-attr switches) - " " - file-name - (if (stringp file-type) ; is a symbolic link - (concat " -> " file-type) - "") - "\n" - ))) - -(defun dired-lisp-time-index (switches) - ;; Return index into file-attributes according to ls SWITCHES. - (cond - ((memq ?c switches) 6) ; last mode change - ((memq ?u switches) 4) ; last access - ;; default is last modtime - (t 5))) - -(defun dired-lisp-format-time (file-attr switches) - ;; Format time string for file with attributes FILE-ATTR according - ;; to SWITCHES (a list of ls option letters of which c and u are recognized). - ;; file-attributes's time is in a braindead format - ;; Emacs 19 can format it using a new optional argument to - ;; current-time-string, for Emacs 18 we just return the faked fixed - ;; date "Jan 00 00:00 ". - (condition-case error-data - (let* ((time (current-time-string - (nth (dired-lisp-time-index switches) file-attr))) - (date (substring time 4 11)) ; "Apr 30 " - (clock (substring time 11 16)) ; "11:27" - (year (substring time 19 24)) ; " 1992" - (same-year (equal year (substring (current-time-string) 19 24)))) - (concat date ; has trailing SPC - (if same-year - ;; this is not exactly the same test used by ls - ;; ls tests if the file is older than 6 months - ;; but we can't do time differences easily - clock - year))) - (error - "Jan 00 00:00"))) - -(provide 'dired-lisp) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-nstd.el --- a/lisp/dired/dired-nstd.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,438 +0,0 @@ -;;; -*- Mode:Emacs-Lisp -*- -;;; Jamie Zawinski 7-may-91 -;;; -;;; This makes dired buffers which display multiple directories display -;;; them in a tree rather than in an "ls -R"-like format. Which, as every -;;; Lisp Machine hacker knows, is the Right Thing! -;;; -;;; -rw-r--r-- 1 jwz 31543 Mar 26 03:20 reportmail.el -;;; -rw-r--r-- 1 jwz 14919 Mar 26 03:20 reportmail.elc -;;; drwxr-xr-x 2 jwz 1024 Apr 5 13:08 sk-dired/ -;;; -rw-r--r-- 1 jwz 3258 Mar 6 06:33 ange-ftp-dired.el -;;; -rw-r--r-- 1 jwz 1750 Mar 12 15:04 ange-ftp-dired.elc -;;; -rw-r--r-- 1 jwz 3151 Mar 29 00:01 symbol-syntax.el -;;; -rw-r--r-- 1 jwz 1504 Mar 29 01:01 symbol-syntax.elc - -;;; 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(defconst dired-subdir-alist nil - "Association list of subdirectories and their buffer positions: - - ((LASTDIR STARTMARKER ENDMARKER NESTING-DEPTH) - ... - (DEFAULT-DIRECTORY POINTMIN POINTMAX 0)). -" -;;The markers point right at the end of the line, so that the cursor -;;looks at either \\n or \\r, the latter for a hidden subdir. -;; The directories must be file-name-as-directory, of course. -) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (set (make-local-variable 'dired-subdir-alist) - (list (list default-directory - (point-min-marker) (point-max-marker) 0)))) - -(define-key dired-mode-map "i" 'dired-insert-subdir-inline) -(define-key dired-mode-map "j" 'dired-maybe-insert-subdir) - -;;; ## these should be macros when this is integrated with the distribution. -(defun dired-get-subdir-min (elt) (nth 1 elt)) -(defun dired-get-subdir-max (elt) (nth 2 elt)) - -(defun dired-subdir-min () - (let ((d (dired-current-directory)) - c) - (if (setq c (assoc d dired-subdir-alist)) - (marker-position (dired-get-subdir-min c)) - (error "not in a subdir!")))) - -(defun dired-subdir-max () - (let ((d (dired-current-directory)) - c) - (if (setq c (assoc d dired-subdir-alist)) - (marker-position (dired-get-subdir-max c)) - (point-max)))) - -(defun dired-clear-alist () - (while dired-subdir-alist - (let ((elt (car dired-subdir-alist))) - (set-marker (nth 1 elt) nil) - (set-marker (nth 2 elt) nil)) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist. - ;; also remove any directories which are inside of it. - (let* ((elt (assoc dir dired-subdir-alist)) - (min (nth 1 elt)) - (max (nth 2 elt)) - other-elt - (rest dired-subdir-alist)) - (while rest - (setq other-elt (car rest)) - (if (and (<= min (nth 1 other-elt)) - (>= max (nth 2 other-elt))) - (setq dired-subdir-alist (delq other-elt dired-subdir-alist))) - (setq rest (cdr rest))))) - -;;; this needs to be changed to grok indentation. Or not. -jwz -;;; Probably not, as dired-revert either starts with one dir and inserting -;;; then enlarges the alist automatically, or it inserts all dirs with -;;; one "ls -lR". -sk -(defun dired-build-subdir-alist () - "Build dired-subdir-alist by parsing the buffer and return it's new value." - (interactive) - (dired-clear-alist) - (save-excursion - (let ((count 0)) - (goto-char (point-min)) - (setq dired-subdir-alist nil) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (dired-alist-add (buffer-substring (match-beginning 1) - (match-end 1)) - ;; Put subdir boundary between lines: - (save-excursion - (goto-char (match-beginning 0)) - (beginning-of-line) - (point-marker)) - ;; isn't this wrong when already more than one - ;; subdir is present with -lR? - ;; maybe. I don't know. But we can't call - ;; dired-subdir-max here, it loops. -jwz. - (point-max-marker) - 0) - (message "%d" count)) - (message "%d director%s." count (if (= 1 count) "y" "ies")) - ;; return new alist: - dired-subdir-alist))) - -(defun dired-alist-add (dir start-marker end-marker indentation-depth) - ;; indentation-depth may be 0 for more than one directory -- this happens - ;; when "ls -R" format is used. - ;; ## debugging code - (or start-marker (error "start marker nil")) - (or end-marker (error "end marker nil")) - ;;(or (/= start-marker end-marker) (error "markers are the same")) - (let ((old (assoc dir dired-subdir-alist))) - (setq dired-subdir-alist - (cons (list (dired-normalize-subdir dir) - start-marker end-marker - (or indentation-depth 0)) - (delq old dired-subdir-alist))) - (dired-alist-sort))) - -;; can't see at the moment how this could work with a mixed format -;; alist -sk -(defun dired-current-directory (&optional relative) - "Get the subdirectory to which this line belongs. -This returns a string with trailing slash, like default-directory. -Optional argument means return a name relative to default-directory." - (let (elt - (here (point)) - (alist (or dired-subdir-alist (dired-build-subdir-alist))) - best-so-far) - (while alist - (setq elt (car alist)) - (if (or (< here (nth 1 elt)) - (> here (nth 2 elt))) - nil ;; the subdir is disjoint - ;; otherwise it's on the path between the current file and the root. - ;; decide if it's deeper than what we've already got. - (if (or (null best-so-far) - (< (- (nth 2 elt) (nth 1 elt)) - (- (nth 2 best-so-far) (nth 1 best-so-far)))) - (setq best-so-far elt))) - (setq alist (cdr alist))) - (if best-so-far - (if relative - (dired-make-relative (car best-so-far) default-directory) - (car best-so-far)) - (progn - (dired-build-subdir-alist) - (dired-current-directory relative))))) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element)) - (end-marker (dired-get-subdir-max element))) - (goto-char end-marker) - (or (eobp) - (not (= 0 (nth 3 element))) - ;; for -R style, want a separating newline _between_ subdirs. - (forward-char -1)) - (if (= 0 (nth 3 element)) - (insert "\n\n")) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - - -(defun dired-insert-subdir-doupdate (dirname elt beg-end) - (let ((beg (nth 0 beg-end)) - (end (nth 1 beg-end)) - (indent (or (nth 2 beg-end) 0))) - (if (and elt - (not (eq indent (nth 2 elt)))) - (setq elt nil - dired-subdir-alist (delq elt dired-subdir-alist))) - (if elt - (let ((old-start (nth 1 elt)) - (old-end (nth 2 elt))) - (set-marker old-start beg) - (set-marker old-end end) - (setcar (nthcdr 3 elt) indent)) - (dired-alist-add dirname - (set-marker (make-marker) beg) - (set-marker (make-marker) end) - indent)))) - -(defun dired-insert-subdir-inline (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it, indented, within its parent's listing. -With a prefix arg, you may edit the ls switches used for this listing. - This command ignores the `R' switch." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (if (let ((case-fold-search nil)) - (string-match "R" (or switches ""))) - (setq switches (concat (substring switches 0 (match-beginning 0)) - (substring switches (match-end 0))))) - (dired-make-relative dirname default-directory) ; error on failure - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - (parentdir (file-name-directory (directory-file-name dirname))) - beg end old-start old-end new-start new-end - mark-alist - tail-adjascents - buffer-read-only case-fold-search) - (if elt - ;; subdir is already present - must first erase it from buffer. - ;; if it's already in -R format, pretend it wasn't there, but - ;; remember its file marks. - (progn - (setq mark-alist - (append (dired-insert-subdir-del elt) mark-alist)) - (setq dired-subdir-alist - (delq elt dired-subdir-alist)))) - ;;(dired-insert-subdir-newpos) ;## - (dired-goto-file dirname) - (forward-line 1) - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-inline-doinsert dirname switches parentdir)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist))) - (dired-nuke-extra-newlines) - ) - - -(defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else appends at end of buffer. -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (dired-make-relative dirname default-directory) ; error on failure - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - (switches-have-R (and switches (string-match "R" switches))) - mark-alist - buffer-read-only case-fold-search) - (if switches-have-R ; avoid double subdirs - (setq mark-alist (dired-kill-tree dirname t))) - (let ((was-nested (and (nth 3 elt) (not (eq 0 (nth 3 elt)))))) - (if elt ; subdir is already present - (setq mark-alist ; remove it, remembering marks - (append (dired-insert-subdir-del elt) mark-alist))) - (if (or was-nested (null elt)) - (dired-insert-subdir-newpos dirname)) - (if was-nested (setcar (nthcdr 3 elt) 0))) - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-doinsert dirname switches)) - (if switches-have-R (dired-build-subdir-alist)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist))) - (dired-nuke-extra-newlines)) - -(defun dired-nuke-extra-newlines () - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\n\n\n+" nil t) - (goto-char (+ 2 (match-beginning 0))) - (delete-region (point) (match-end 0)))))) - - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - ;;(goto-char (point-max)) - (let ((alist dired-subdir-alist) elt dir pos new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (and (= 0 (nth 3 elt)) ; nested ones don't count. - (dired-tree-lessp dir new-dir)) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (insert "\n\n") - (point)) - - -(defvar dired-no-inline-headerlines t - "*set this to t to suppress the directory header and `total' line.") - - -(defun dired-insert-subdir-inline-doinsert (dirname switches parentdir) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; returns the dired-subdir-alist entry. - (let ((begin (point)) end - indent - tail-adjascents) - (message "Reading directory %s..." dirname) - (dired-ls dirname - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)) - nil t) - (message "Reading directory %s...done" dirname) - (setq end (point)) - (setq indent (1+ (nth 3 (assoc parentdir dired-subdir-alist)))) - - (save-excursion - (goto-char begin) - (or dired-no-inline-headerlines - (progn - (dired-insert-headerline dirname) - (save-excursion (delete-horizontal-space))) - (goto-char begin) - (delete-horizontal-space)) - (if (and dired-no-inline-headerlines - (looking-at "^ *total [0-9]")) - (progn - (delete-region (point) (progn (forward-line 1) (point))) - (setq begin (point))))) - ;; - ;; If there are other directories whose end-point is right here, - ;; then they are the directories such that X is the last directory - ;; in the listing of Y. We need to grab them and update their - ;; last-point to be the same as ours will be (goofy margin-case). - ;; - (let ((rest dired-subdir-alist)) - (while rest - (if (= (point) (nth 2 (car rest))) - (setq tail-adjascents (cons (car rest) tail-adjascents))) - (setq rest (cdr rest)))) - (let ((indent-tabs-mode nil)) - (indent-rigidly begin (point) (* 2 (1+ indent)))) - (setq end (point-marker)) - (goto-char begin) - (while tail-adjascents - (set-marker (nth 2 (car tail-adjascents)) end) - (setq tail-adjascents (cdr tail-adjascents))) - (if dired-after-readin-hook - (save-restriction - (narrow-to-region begin end) - (run-hooks 'dired-after-readin-hook))) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - (setq end (prog1 (marker-position end) (set-marker end nil))) - (goto-char begin) - (list begin end indent))) - - -(defun dired-insert-subdir-doinsert (dirname switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - (let ((begin (point)) end) - (message "Reading directory %s..." dirname) - (dired-ls dirname - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)) - nil t) - (message "Reading directory %s...done" dirname) - (insert "\n\n") - (setq end (point-marker)) - (indent-rigidly begin (point) 2) - (if dired-after-readin-hook - (save-restriction - (narrow-to-region begin (point)) - (run-hooks 'dired-after-readin-hook))) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (setq end (prog1 (marker-position end) (set-marker end nil))) - (list begin end))) - - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (or (string-match "R" dired-actual-switches) - (let (elt dir) - (setq old-subdir-alist (sort old-subdir-alist - (function (lambda (x y) - (< (nth 3 x) (nth 3 y)))))) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt)) - (condition-case () - (if (= 0 (nth 3 elt)) - (dired-insert-subdir dir) - (dired-insert-subdir-inline dir)) - (error nil)))))) - -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space, plus nesting indentation. - ;; Uses fluid vars `directory', `marker-char' from dired-add-entry - (insert (if marker-char - (if (integerp marker-char) marker-char dired-marker-char) - ?\040) - ?\040) - (let ((indent (nth 3 (assoc directory dired-subdir-alist)))) - (insert (make-string (* 2 indent) ?\040)))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-num.el --- a/lisp/dired/dired-num.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -;;;; dired-num.el - Renaming with numbers in Tree Dired. - -(defconst dired-num-version (substring "!Revision: 1.2 !" 11 -2) - "Id: dired-num.el,v 1.2 1991/10/15 13:24:10 sk RelBeta ") - -;; Copyright (C) 1991 by Sebastian Kremer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-num|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Renaming with numbers in Tree Dired. -;; |Date: 1991/10/15 13:24:10 |Revision: 1.2 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-do-rename-numeric "dired-num") -;; (autoload 'dired-do-rename-list "dired-num") -;; -;; Do -;; -;; (define-key dired-mode-map "%#" 'dired-do-rename-numeric) -;; (define-key dired-mode-map "%(" 'dired-do-rename-list) -;; -;; inside your dired-load-hook. - -(require 'dired);; we need its macros when being compiled - -(defun dired-number-of-marked-files (&optional arg) - ;; Return the number of marked files in a dired buffer. - ;; Optional ARG as in dired-mark-map. - (length - (save-excursion - ;; this returns a list of ``results'' (i.e. nil's): - (dired-mark-map nil arg)))) - -(defun dired-do-create-files-numeric (file-creator operation arg format start - &optional arg) - ;; Create a new file for each marked file using numbers. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; FORMAT is a format string for use with an integer, assuming - ;; values starting from START, incremented for each marked file. - (let ((i (1- start)));; signals an error if START is not a number - (dired-create-files-non-directory - file-creator - (function (lambda (x) - (format format (setq i (1+ i))))) - operation arg))) - -;;;###autoload -(defun dired-do-rename-numeric (format start &optional arg) - "Rename all marked (or next ARG) files using numbers. -You are prompted for a format string, e.g \"part_%d_of_8\", and a starting -number, e.g. 1. If there are 8 marked files, this example will rename them to - - part_1_of_8 - part_2_of_8 - ... - part_8_of_8" - (interactive - (list - (read-string - (format "Rename numeric [%d files] (format string using %%d): " - (dired-number-of-marked-files current-prefix-arg))) - (read-minibuffer "Numbers start at: " "1") - current-prefix-arg)) - (dired-do-create-files-numeric - (function dired-rename-file) - "Rename-numeric" arg format start)) - -;; Copy etc. would be similar to implement. - - -(defun dired-do-create-files-list (file-creator operation arg format list - &optional arg) - ;; Create a new file for each marked file by subsituting elements - ;; from LIST in the format string FORMAT. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - (let ((rest list)) - (dired-create-files-non-directory - file-creator - (function (lambda (x) - (format format (prog1 - (car rest) - (setq rest (cdr rest)))))) - operation arg))) - -;;;###autoload -(defun dired-do-rename-list (format list &optional arg) - "Rename all marked (or next ARG) files using elements from LIST. -You are prompted for a format string, e.g \"x_%s\", and the list, -e.g. '(foo bar zod). This example will rename the marked files to - - x_foo - x_bar - x_zod - -It is an error if LIST has not as many elements as there are files." - (interactive "sRename list (format using %%s): \nxList: \nP") - (or (= (dired-number-of-marked-files arg) - (length list)) - (error "Must have as many elements as there are files to rename")) - (dired-do-create-files-list - (function dired-rename-file) - "Rename-list" arg format list)) - diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-rcs.el --- a/lisp/dired/dired-rcs.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -;;;; dired-rcs.el - RCS support for Tree Dired - -(defconst dired-rcs-version (substring "!Revision: 1.6 !" 11 -2) - "I don't speak RCS-ese") - -;; Originally written by Sebastian Kremer -;; Rewritten by Heiko Muenkel - -;; Copyright (C) 1991 by Sebastian Kremer -;; Copyright (C) 1994 by Heiko Muenkel - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; INSTALLATION ====================================================== -;; -;; This will not work with classic (18.xx) Dired, you'll need Tree Dired, -;; available via anonymous ftp from -;; -;; ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs") -;; (autoload 'dired-rcs-mark-rcs-files "dired-rcs") -;; -;; Put this inside your dired-load-hook: -;; -;; (define-key dired-mode-map "," 'dired-rcs-mark-rcs-files) -;; (define-key dired-mode-map "\M-," 'dired-rcs-mark-rcs-locked-files) -;; - -(require 'dired) - -;;;###autoload -(defun dired-rcs-mark-rcs-locked-files (&optional unflag-p) - "Mark all files that are under RCS control and RCS-locked. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - (interactive "P") - (dired-rcs-mark-rcs-files unflag-p t)) - -;;;###autoload -(defun dired-rcs-mark-rcs-files (&optional unflag-p locked) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns list of failures, or nil on success. - ;; Optional arg LOCKED means just mark RCS-locked files. - (interactive "P") - (message "%s %sRCS controlled files..." - (if unflag-p "Unmarking" "Marking") - (if locked "locked " "")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - ;; Loop over subdirs to set `rcs-files' - (mapcar - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (if locked - ;; these two functions from sk's rcs.el - (rcs-locked-files dir) - (rcs-files dir)) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (rcs-working-file (car rcs-files)) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark-file 1) - (dired-log "RCS working file not found: %s\n" wf) - (setq failures (cons (dired-make-relative wf) - failures))))) - (if (null failures) - (message "%d %sRCS file%s %smarked." - total - (if locked "locked " "") - (dired-plural-s total) - (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary "RCS working file not found %s" failures) - (message "%d %sRCS file%s: %d %smarked - %d not found %s." - total - (if locked "locked " "") - (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - -(defun rcs-files (directory) - "Return list of RCS data files for all RCS controlled files in DIRECTORY." - (setq directory (file-name-as-directory directory)) - (let ((rcs-dir (file-name-as-directory (expand-file-name "RCS" directory))) - (rcs-files (directory-files directory t ",v$"))) - (if (file-directory-p rcs-dir) - (setq rcs-files - (append (directory-files rcs-dir t ",v$") - rcs-files))) - rcs-files)) - -(defvar rcs-output-buffer "*RCS-output*" - "If non-nil, buffer name used by function `rcs-get-output-buffer' (q.v.). -If nil, a new buffer is used each time.") - -(defun rcs-get-output-buffer (file) - ;; Get a buffer for RCS output for FILE, make it writable and clean - ;; it up. Return the buffer. - ;; The buffer used is named according to variable - ;; `rcs-output-buffer'. If the caller wants to be reentrant, it - ;; should let-bind this to nil: a new buffer will be chosen. - (let* ((default-major-mode 'fundamental-mode);; no frills! - (buf (get-buffer-create (or rcs-output-buffer "*RCS-output*")))) - (if rcs-output-buffer - nil - (setq buf (generate-new-buffer "*RCS-output*"))) - (save-excursion - (set-buffer buf) - (setq buffer-read-only nil - default-directory (file-name-directory (expand-file-name file))) - (erase-buffer)) - buf)) - -(defun rcs-locked-files (directory) - "Return list of RCS data file names of all RCS-locked files in DIRECTORY." - (let ((output-buffer (rcs-get-output-buffer directory)) - (rcs-files (rcs-files directory)) - result) - (and rcs-files - (save-excursion - (set-buffer output-buffer) - (apply (function call-process) "rlog" nil t nil "-L" "-R" rcs-files) - (goto-char (point-min)) - (while (not (eobp)) - (setq result (cons (buffer-substring (point) - (progn (forward-line 1) - (1- (point)))) - result))) - result)))) - -(defun rcs-working-file (filename) - "Convert an RCS file name to a working file name. -That is, convert `...foo,v' and `...RCS/foo,v' to `...foo'. -If FILENAME doesn't end in `,v' it is returned unchanged." - (if (not (string-match ",v$" filename)) - filename - (setq filename (substring filename 0 -2)) - (let ((dir (file-name-directory filename))) - (if (null dir) - filename - (let ((dir-file (directory-file-name dir))) - (if (equal "RCS" (file-name-nondirectory dir-file)) - ;; Working file for ./RCS/foo,v is ./foo. - ;; Don't use expand-file-name as this converts "" -> pwd - ;; and thus forces a relative FILENAME to be relative to - ;; the current value of default-directory, which may not - ;; what the caller wants. Besides, we want to change - ;; FILENAME only as much as necessary. - (concat (file-name-directory dir-file) - (file-name-nondirectory filename)) - filename)))))) - -(defun dired-do-vc-register (&optional arg) - "Register the marked (or next ARG) files under version control." - (interactive "P") - (dired-mark-map-check (function dired-vc-register) arg 'register t)) - -(defun dired-vc-register () - (let ((file (dired-get-filename)) failure) - (condition-case err - (save-window-excursion - (find-file file) - (vc-register)) - (error (setq failure err))) - (if (not failure) - nil - (dired-log "Register error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(provide 'dired-rcs) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-trns.el --- a/lisp/dired/dired-trns.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -;; dired-trns.el - file transformers for dired shell commands. - -;; Id: dired-trns.el,v 1.6 1991/07/05 13:36:01 sk RelBeta - -;; Code contributed by Hans Chalupsky . -;; Integrated with my dired.el sk@sparc0 11-Jan-1991 14:38. -;; And hacked up a bit. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-trns|Hans Chalupsky|hans@cs.Buffalo.EDU -;; |Filename Transformation for Tree Dired Shell Commands -;; |Date: 1991/07/05 13:36:01 |Revision: 1.6 | - -;; INSTALLATION ====================================================== -;; Put this file into your load-path and add (load "dired-trns") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-trns"))) - -;; Transformers are functions that take a file (a string) as an argument -;; and transform it into some other string (e.g., a filename without an -;; extension). -;; -;; Each transformer is associated with a dispatch character. The associations -;; are stored in a keymap for fast and easy lookup. The dispatch character -;; is used to activate the associated transformer function at a particular -;; position in a shell command issued in dired. -;; -;; Transformers can be used to construct complicated shell commands that -;; operate on a large number of files, for example, they allow to create -;; functionality such as "mv *.lsp *.lisp" where each .lsp file is -;; renamed into a a file with same name but new extension .lisp. - -(defvar dired-trans-map (make-keymap) - "Array that associates keys with file transformer functions") - -(defmacro dired-trans-define (char &rest body) - "Macro that assigns the transformer function (lambda (file) BODY) to -CHAR (a character or string). BODY must return a string (the transformed -file or whatever. This macro allows easy definition of user specific -transformation functions." - (if (not (stringp char)) (setq char (char-to-string char))) - (list 'define-key 'dired-trans-map char - (list 'function (append '(lambda (file)) body)))) - -(defun dired-trans-run (transformers file) - "Applies each transformer supplied in the string TRANSFORMERS in sequence -to FILE and returns the concatenation of the results." - (mapconcat (function - (lambda (transformer) - (setq transformer (char-to-string transformer)) - (funcall (or (lookup-key dired-trans-map transformer) - (error "Undefined transfomer: %s" transformer)) - file))) - transformers nil)) - -(defvar dired-trans-re-ext "\\.[^.]*\\(\\.\\(\\(g?z\\)\\|Z\\)\\)?$" - "The part of a filename matching this regexp will be viewed as extension") - -(defun dired-trans-init () - "Defines a basic set of useful transformers. - -* is a noop that returns the unmodified filename (equivalent to [dbe]). -n returns the Name component of a filename without directory information -d returns the Directory component of a filename -b returns the Basename of a filename, i.e., the name of the file without - directory and extension (see dired-trans-re-ext) - A basename with directory component can be obtained by [db]. -e returns the Extension of a filename (i.e., whatever - dired-trans-re-ext splits off) -v returns a file without directory and without ,v suffixes if any. -z returns a file without directory and without .Z .z .gz suffixes if any." - (dired-trans-define - "*" file) - (dired-trans-define - "n" (or (file-name-nondirectory file) "")) - (dired-trans-define - "d" (or (file-name-directory file) "")) - (dired-trans-define - "b" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match dired-trans-re-ext file))) - (dired-trans-define - "e" (let ((e (string-match dired-trans-re-ext file))) - (if e - (substring file e) - ""))) - (dired-trans-define - "v" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match ",v$" file))) - (dired-trans-define - "z" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match "\\.\\(\\(g?z\\)\\|Z\\)$" file))) - ) - -(dired-trans-init) - -(defun dired-trans-mklist (files &optional transformers) - "Takes a list of FILES and applies the sequence of TRANSFORMERS to each -of them. The transformed results are concatenated, separated by -dired-mark-separator, prefixed by dired-mark-prefix and postfixed by -dired-mark-postfix to generate a file list suitable for a particular shell." - (if (not (consp files))(setq files (list files))) - (if (null transformers) (setq transformers "*")) - (let ((file-list - (mapconcat (function - (lambda (file) - (shell-quote - (dired-trans-run transformers file)))) - files dired-mark-separator))) - (if (> (length files) 1) - (concat dired-mark-prefix file-list dired-mark-postfix) - file-list))) - -;; By default, transformations can be specified like this: -;; [db] or [dv] or #z# or #dbe# or #dbe (blank at the end). - -(defvar dired-trans-starters "[#[]" - "User definable set of characters to be used to indicate the start of a -transformer sequence") - -(defvar dired-trans-enders "[]# ]" - "User definable set of characters to be used to indicate the end of a -transformer sequence") - -(defun dired-trans-expand (command files) - "Takes a shell COMMAND and a list of FILES and substitutes each occurance -of a transformer sequence by an accordingly transformed file list. Special -characters such as [,] or * can be quoted with a backslash." - (let ((quoted nil) - (collect-transformers nil) - (transformers "")) - (mapconcat (function - (lambda (char) - (setq char (char-to-string char)) - (cond (quoted (setq quoted nil) char) - ((equal char "\\") (setq quoted t) nil) - (collect-transformers - (cond ((string-match dired-trans-enders char) - (setq collect-transformers nil) - (prog1 (dired-trans-mklist - files transformers) - (setq transformers ""))) - (t (setq transformers - (concat transformers char)) - nil))) - ((string-match dired-trans-starters char) - (setq collect-transformers t) nil) - ;; for compatibility and as a special case that should - ;; not be redefinable by the user (used below) - ((equal char "*") - (dired-trans-mklist files "*")) - (t char)))) - command nil))) - -(defun dired-trans-make (command files &optional all-at-once) - "Takes a shell COMMAND and a list of FILES and returns a command operating -on the list of files (transformed if COMMAND contains transformers). If -ALL-AT-ONCE is t the resulting command will be of the form - cmd file1 file2 ... fileN -otherwise it will be - cmd file1; cmd file2; ... cmd fileN; -Both examples assume a single reference to the file list." - (let (fns expanded-command) - (cond (all-at-once - (setq expanded-command (dired-trans-expand command files)) - (if (equal command expanded-command) - (concat command (dired-trans-expand " *" files)) - expanded-command)) - (t (mapconcat - (function - (lambda (file) - (dired-trans-make command file t))) - files ";"))))) - -;; Redefine this function from dired.el: - -(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) -"Make up a shell command line from COMMAND and FILE-LIST. -If ON-EACH is t, COMMAND should be applied to each file, else - simply concat all files. -The list of marked files is appended to the command string unless asterisks - `*' or transformer sequences enclosed in `[]' indicate the place(s) where - the (transformed) list should go. See documentation of function - dired-trans-init for a list of transformers. -With a zero argument the resulting command will be of the form - cmd file1; cmd file2; ... cmd fileN assuming only one reference to the - file list. E.g., to rename all .lsp files into .lisp files mark all the - .lsp files and issue the command `mv * [db].lisp' ." - (dired-trans-make command file-list (not on-each))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-vms.el --- a/lisp/dired/dired-vms.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,279 +0,0 @@ -;; dired-vms.el - VMS support for dired. Revision: 1.17 -;; Copyright (C) 1990, 1992 Free Software Foundation, Inc. - -;; 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 -;; 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. - -;; 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. - -;; Id: dired-vms.el,v 1.17 1991/09/09 16:54:03 sk RelBeta - -;; You'll need vmsproc.el for this function: -(autoload 'subprocess-command-to-buffer "vmsproc") - -(setq dired-subdir-regexp "^ *Directory \\([][:.A-Z-0-9_$;<>]+\\)\\(\\)[\n\r]") - -(defconst dired-vms-filename-regexp -"\\(\\([_A-Z0-9$]?\\|[_A-Z0-9$][_A-Z0-9$---]*\\)\\.[_A-Z0-9$---]*;+[0-9]*\\)" - "Regular expression to match for a valid VMS file name in Dired buffer. -Stupid freaking bug! Position of _ and $ shouldn't matter but they do. -Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX -Other orders of $ and _ seem to all work just fine.") - -(setq dired-re-mark "^[^ \n\t]") - -(defvar dired-directory-command - "DIRECTORY/SIZE/DATE/PROT" - "Directory command for dired under VMS.") - -;; requires vmsproc.el to work -(defun dired-ls (file switches &optional wildcard full-directory-p) - "Insert ls output of FILE,formatted according to SWITCHES. -Optional third arg WILDCARD means treat FILE as shell wildcard. -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d'. - -SWITCHES default to dired-listing-switches. - -This is the VMS version of this UNIX command. -The SWITCHES and WILDCARD arguments are ignored. -Uses dired-directory-command." - (save-restriction;; Must drag point along: - (narrow-to-region (point) (point)) - (subprocess-command-to-buffer - (concat dired-directory-command " " file) - (current-buffer)) - (if full-directory-p - (goto-char (point-max)) - ;; Just the file line if no full directory required: - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward dired-subdir-regexp) - (re-search-forward (concat "^" dired-vms-filename-regexp))) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))))) - -(defun dired-insert-headerline (dir) ; redefinition - ;; VMS dired-ls makes its own headerline, but we must position the - ;; cursor where dired-insert-subdir expects it. - ;; This does not check whether the headerline matches DIR. - (re-search-forward dired-subdir-regexp) - (goto-char (match-end 1))) - - -(defun dired-make-absolute (file &optional dir) - ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname." - ;; This should be good enough for ange-ftp, but might easily be - ;; redefined (for VMS?). - ;; It should be reasonably fast, though, as it is called in - ;; dired-get-filename. - (concat (or dir - (dired-current-directory) - default-directory) - file)) - -(defun dired-make-relative (file &optional dir) - ;; In VMS we don't want relative names at all because of search path - ;; logical names. Also, we never need to raise an error when a file - ;; `doesn't belong' in this buffer (like in the Unix case). - file) - -(defun dired-in-this-tree (file dir) - ;;"Is FILE part of the directory tree starting at DIR?" - ;; Under VMS, file="DEV:[foo.bar]zod", dir="DEV:[foo]" - (or (string= (substring dir -1) "\]") - (string= (substring dir -1) "\:") - (error "Not a directory: %s" dir)) - (string-match (concat "^" (regexp-quote (substring dir 0 -1))) - file)) - -(defun dired-vms-split-filename (file) - (if (string-match;; "DEV:[DIR]FIL" \1=DEV \2=DIR \3=FIL - "^\\([.A-Z-0-9_$;]*\\):?[[<]\\([.A-Z-0-9_$;]*\\)[]>]\\([.A-Z-0-9_$;]*\\)$" - file) - (mapcar '(lambda (x) - (substring file (match-beginning x) (match-end x))) - '(1 2 3)))) - -;; Must use this in dired-noselect instead of expand-file-name and -;; file-name-as-directory -;; Taken from the VMS dired version by -;;Roland Roberts BITNET: roberts@uornsrl -;; Nuclear Structure Research Lab INTERNET: rbr4@uhura.cc.rochester.edu -;; 271 East River Road UUCP: rochester!ur-cc!uhura!rbr4 -;; Rochester, NY 14267 AT&T: (716) 275-8962 - - -(defun dired-noselect (dirname &optional switches) - "Like M-x dired but returns the dired buffer as value, does not select it." - (setq dirname (dired-fix-directory dirname)) - (dired-internal-noselect dirname switches)) - -(defun dired-fix-directory (dirname) - "Fix up dirname to be a valid directory name and return it" - (setq dirname - (expand-file-name (or dirname (setq dirname default-directory)))) - (let ((end (1- (length dirname))) - bracket colon) - (if (or (char-equal ?\] (elt dirname end)) - (char-equal ?\: (elt dirname end))) - dirname - (setq bracket (string-match "\\]" dirname)) - (setq colon (string-match "\\:" dirname)) - (setq end (string-match "\\.DIR" dirname (or bracket colon))) - (if end - (let ((newdir - (if bracket (concat (substring dirname 0 bracket) - ".") - (if colon (concat (substring dirname 0 (1+ colon)) - "[") - "[")))) - (concat newdir (substring dirname - (1+ (or bracket colon)) end) - "]")) - (if bracket (substring dirname 0 (1+ bracket)) - (if colon (substring dirname 0 (1+ colon)) - default-directory)))))) - -;; Versions are not yet supported in dired.el (as of version 4.53): -;;(setq dired-file-version-regexp "[.;][0-9]+$") - -(defun dired-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the VMS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward (concat " " dired-vms-filename-regexp) eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line") - nil))) - -(defun dired-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* line. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let (opoint flag ex sym hidden case-fold-search) - (setq opoint (point)) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (re-search-forward dired-vms-filename-regexp eol t)) - (or no-error - (not (eq opoint (point))) - (error (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(defun dired-tree-lessp (dir1 dir2) - (setq dir1 (substring (file-name-as-directory dir1) 0 -1) - dir2 (substring (file-name-as-directory dir2) 0 -1)) - (let ((components-1 (dired-split "[:.]" dir1)) - (components-2 (dired-split "[:.]" dir2))) - (while (and components-1 - components-2 - (equal (car components-1) (car components-2))) - (setq components-1 (cdr components-1) - components-2 (cdr components-2))) - (let ((c1 (car components-1)) - (c2 (car components-2))) - - (cond ((and c1 c2) - (string-lessp c1 c2)) - ((and (null c1) (null c2)) - nil) ; they are equal, not lessp - ((null c1) ; c2 is a subdir of c1: c1c2 - nil) - (t (error "This can't happen")))))) - -(defun dired-insert-subdir-validate (dirname) - (let ((alist dired-subdir-alist) - (found nil) - item) - (while (and alist (not found)) - (setq item (car alist) - alist (cdr alist)) - (setq found (dired-in-this-tree dirname (car item)))) - (if (not found) - (error "%s: directory not in this buffer" dirname)))) - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist (reverse dired-subdir-alist)) elt dir pos new-pos found) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (or (and found - (or (dired-in-this-tree dir found) - (setq alist nil))) - (and (dired-in-this-tree new-dir dir) - (setq found dir))) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt))))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (or (eobp) - (forward-line -1)) - (insert "\n") - (point)) - -(defun dired-between-files () - (save-excursion - (beginning-of-line) - (or (equal (following-char) 9) - (progn (forward-char 2) - (or (looking-at "Total of") - (equal (following-char) 32)))))) - -(defun dired-buffers-for-dir (dir) - ;; Return a list of buffers that dired DIR (top level or in-situ subdir). - ;; The list is in reverse order of buffer creation, most recent last. - ;; As a side effect, killed dired buffers for DIR are removed from - ;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist)) - ;; In Unix we only looked into the buffer when - ;; (dired-in-this-tree dir (car elt)) returned non-nil. - ;; In VMS we have to look into each buffer because it doesn't - ;; necessarily contain only the tree starting at the top level directory - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (assoc dir (save-excursion - (set-buffer buf) - dired-subdir-alist)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers)))) - (setq alist (cdr alist))) - result)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-x.el --- a/lisp/dired/dired-x.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1679 +0,0 @@ -;;; dired-x.el --- Sebastian Kremer's Extra DIRED hacked up for GNU Emacs19 -;; Keywords: dired extensions - -(defconst dired-extra-version (substring "!Revision: 1.191 !" 11 -2) - "Id: dired-x.el,v 1.191 1992/05/14 11:41:54 sk RelBeta ") - -;; Copyright (C) 1991 Sebastian Kremer. - -;; 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 -;; 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. - -;; 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. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-x|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Extra Features for Tree Dired -;; |Date: 1992/05/14 11:41:54 |Revision: 1.191 | - -;; INSTALLATION ====================================================== - -;; In your ~/.emacs, say -;; -;; (setq dired-load-hook '(lambda () (load "dired-x"))) -;; -;; At load time dired-x will install itself using the various other -;; dired hooks. It will redefine some functions and bind dired keys. -;; If gmhist is present, dired-x will take advantage of it. - -(require 'dired) ; we will redefine some functions - ; and also need some macros - -(provide 'dired-extra) ; but this file is "dired-x" -(provide 'dired-x) ; but this file is "dired-x" - -;; Customization (see also defvars in other sections below) - -;; user should define this as `nil' prior to loading dired-x in order that the -;; compression/decompression material of emacs19 is not overwritten. -(defvar dired-mark-keys '("Z") - "*List of keys (strings) that insert themselves as file markers.") - -(defvar dired-dangerous-shell-command "^rm" ; e.g. "rm" or "rmdir" - "*Regexp for dangerous shell commands that should never be the default.") - -;; Add key bindings. This file is supposed to be loaded immediately -;; after dired, inside dired-load-hook. - -(define-key dired-mode-map "V" 'dired-vm) -(define-key dired-mode-map "\(" 'dired-set-marker-char) -(define-key dired-mode-map "\)" 'dired-restore-marker-char) -(define-key dired-mode-map "I" 'dired-do-insert-subdir) -;;(define-key dired-mode-map "\M-f" 'dired-flag-extension) -(define-key dired-mode-map "\M-M" 'dired-do-unmark) -(define-key dired-mode-map "\M-o" 'dired-omit-toggle) -(define-key dired-mode-map "\M-(" 'dired-mark-sexp) -(define-key dired-mode-map "," 'dired-mark-rcs-files) -(define-key dired-mode-map "\M-!" 'dired-smart-shell-command) -(define-key dired-mode-map "\M-&" 'dired-smart-background-shell-command) -(define-key dired-mode-map "T" 'dired-do-toggle) -(define-key dired-mode-map "w" 'dired-copy-filename-as-kill) -(define-key dired-mode-map "\M-g" 'dired-goto-file) -(define-key dired-mode-map "\M-G" 'dired-goto-subdir) -(define-key dired-mode-map "&" 'dired-do-background-shell-command) -(define-key dired-mode-map "A" 'dired-do-byte-compile-and-load) -(define-key dired-mode-map "F" 'dired-do-find-file) -(define-key dired-mode-map "S" 'dired-do-relsymlink) -(define-key dired-mode-map "%S" 'dired-do-relsymlink-regexp) - -(mapcar (function;; do this last to override bindings above - (lambda (x) - (define-key dired-mode-map x 'dired-mark-with-this-char))) - dired-mark-keys) - -;; Install ourselves into the appropriate hooks - -(defun dired-add-hook (hook-var function) - "Add a function to a hook. -First argument HOOK-VAR (a symbol) is the name of a hook, second -argument FUNCTION is the function to add. -Returns nil if FUNCTION was already present in HOOK-VAR, else new -value of HOOK-VAR." - (interactive "SAdd to hook-var (symbol): \naAdd which function to %s? ") - (if (not (boundp hook-var)) (set hook-var nil)) - (if (or (not (listp (symbol-value hook-var))) - (eq (car (symbol-value hook-var)) 'lambda)) - (set hook-var (list (symbol-value hook-var)))) - (if (memq function (symbol-value hook-var)) - nil - (set hook-var (cons function (symbol-value hook-var))))) - -(dired-add-hook 'dired-mode-hook 'dired-extra-startup) -(dired-add-hook 'dired-after-readin-hook 'dired-omit-expunge) - -(defvar dired-default-marker dired-marker-char - "*The value of `dired-marker-char' in effect before dired-x was -loaded and the value which is restored if the marker stack underflows. -This is usually the asterisk `*'.") - -;;;###autoload -(defun dired-extra-startup () - "Automatically put on dired-mode-hook to get extra dired features: -\\ - \\[dired-vm]\t-- VM on folder - \\[dired-rmail]\t-- Rmail on folder - \\[dired-do-insert-subdir]\t-- insert all marked subdirs - \\[dired-do-find-file]\t-- visit all marked files simultaneously - \\[dired-set-marker-char], \\[dired-restore-marker-char]\t-- change and display dired-marker-char dynamically. - \\[dired-omit-toggle]\t-- toggle omitting of files - \\[dired-mark-sexp]\t-- mark by lisp expression - \\[dired-do-unmark]\t-- replace existing marker with another. - \\[dired-mark-rcs-files]\t-- mark all RCS controlled files - \\[dired-mark-files-compilation-buffer]\t-- mark compilation files - \\[dired-copy-filename-as-kill]\t-- copy the file or subdir names into the kill ring. - \t You can feed it to other commands using \\[yank]. - -For more features, see variables - - dired-omit-files - dired-omit-extenstions - dired-dangerous-shell-command - dired-mark-keys - dired-local-variables-file - dired-find-subdir - dired-guess-have-gnutar - dired-auto-shell-command-alist - -See also functions - - dired-sort-on-size - dired-do-relsymlink - dired-flag-extension - dired-virtual - dired-jump-back - dired-jump-back-other-window -" - (interactive) - ;; This must be done in each new dired buffer: - (dired-hack-local-variables) - (dired-omit-startup) - (dired-marker-stack-startup)) - -;;; Handle customization - -(or (fboundp 'read-with-history-in) ; it's loaded - (not (subrp (symbol-function 'read-from-minibuffer))) ; it's 19.4L - ;; else try to load gmhist - (load "gmhist" t)) - -(if (not (fboundp 'read-with-history-in)) - - nil ; Gmhist is not available - - ;; Else use generic minibuffer history - (put 'dired-shell-command-history 'dangerous dired-dangerous-shell-command) - - ;; Redefinition - when this is loaded, dired.el has alreay been loaded. - - (defun dired-read-regexp (prompt &optional initial) - (setq dired-flagging-regexp - (if (null initial) - (read-with-history-in 'regexp-history prompt initial) - (put 'regexp-history 'default - nil) - (put 'regexp-history 'default - (read-with-history-in 'regexp-history prompt initial))))) - - (defun dired-read-dir-and-switches (str) - (nreverse - (list - (if current-prefix-arg - (read-string "Dired listing switches: " dired-listing-switches)) - (read-file-name-with-history-in - 'file-history ; or 'dired-history? - (format "Dired %s(directory): " str) nil default-directory nil)))) -) - - - -;;; Dynamic Markers - -(defun dired-mark-with-this-char (arg) - "Mark the current file or subdir with the last key you pressed to invoke -this command. Else like \\[dired-mark-subdir-or-file] command." - (interactive "p") - (let ((dired-marker-char;; use last character, in case of prefix cmd - last-command-char)) - (dired-mark-subdir-or-file arg))) - -(defvar dired-marker-stack nil - "List of previously used dired marker characters.") - -(defvar dired-marker-string "" - "String version of `dired-marker-stack'.") - -(defun dired-current-marker-string () - "Computes and returns `dired-marker-string'." - (setq dired-marker-string - (concat " " - (mapconcat (function char-to-string) - (reverse dired-marker-stack) - "")))) - -(defun dired-marker-stack-startup () - (make-local-variable 'dired-marker-char) - (make-local-variable 'dired-del-marker) - (make-local-variable 'dired-marker-stack) - (or (assq 'dired-marker-stack minor-mode-alist) - (setq minor-mode-alist - (cons '(dired-marker-stack dired-marker-string) - minor-mode-alist)))) - -(defun dired-set-marker-char (c) - "Set the marker character to something else. -Use \\[dired-restore-marker-char] to restore the previous value." - (interactive "cNew marker character: ") - (setq dired-marker-stack (cons c dired-marker-stack)) - (dired-current-marker-string) - (setq dired-marker-char c) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (message "New marker is %c" dired-marker-char)) - -(defun dired-restore-marker-char () - "Restore the marker character to its previous value. -Uses `dired-default-marker' if the marker stack is empty." - (interactive) - (setq dired-marker-stack (cdr dired-marker-stack) - dired-marker-char (car dired-marker-stack)) - (dired-current-marker-string) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (or dired-marker-char (setq dired-marker-char dired-default-marker)) - (message "Marker is %c" dired-marker-char)) - -;;; Sort on Size kludge if your ls can't do it - -(defun dired-sort-on-size () - "Sorts a dired listing on file size. -If your ls cannot sort on size, this is useful as `dired-after-readin-hook': - \(setq dired-after-readin-hook 'dired-sort-on-size\)" - (require 'sort) - (goto-char (point-min)) - (dired-goto-next-file) ; skip `total' line - (beginning-of-line) - (sort-subr t ; biggest file first - 'forward-line 'end-of-line 'dired-get-file-size)) - -(defun dired-get-file-size () - (re-search-forward "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)") - (goto-char (match-beginning 1)) - (forward-char -1) - (string-to-int (buffer-substring (save-excursion - (backward-word 1) - (point)) - (point)))) - - -;;; Misc. (mostly featurismic) commands - -;; Mail folders - -(defvar dired-vm-read-only-folders nil - "*If t, \\[dired-vm] will visit all folders read-only. -If neither nil nor t, e.g. the symbol `if-file-read-only', only -files not writable by you are visited read-only. - -Read-only folders only work in VM 5, not in VM 4.") - -(defun dired-vm (&optional read-only) - "Run VM on this file. -With prefix arg, visit folder read-only (this requires at least VM 5). -See also variable `dired-vm-read-only-folders'." - (interactive "P") - (let ((dir (dired-current-directory)) - (fil (dired-get-filename))) - ;; take care to supply 2nd arg only if requested - may still run VM 4! - (cond (read-only (vm-visit-folder fil t)) - ((eq t dired-vm-read-only-folders) (vm-visit-folder fil t)) - ((null dired-vm-read-only-folders) (vm-visit-folder fil)) - (t (vm-visit-folder fil (not (file-writable-p fil))))) - ;; so that pressing `v' inside VM does prompt within current directory: - (set (make-local-variable 'vm-folder-directory) dir))) - -(defun dired-rmail () - "Run RMAIL on this file." - (interactive) - (rmail (dired-get-filename))) - -;; More subdir operations - -(defun dired-do-insert-subdir () - "Insert all marked subdirectories in situ that are not yet inserted. -Non-directories are silently ignored." - (interactive) - (let ((files (or (dired-mark-get-files) - (error "No files marked.")))) - (while files - (if (file-directory-p (car files)) - (save-excursion (dired-maybe-insert-subdir (car files)))) - (setq files (cdr files))))) - -(defun dired-mark-extension (extension &optional marker-char) - "Mark all files with a certain extension for use in later commands. -A `.' is not automatically prepended to the string entered." - ;; EXTENSION may also be a list of extensions instead of a single one. - ;; Optional MARKER-CHAR is marker to use. - (interactive "sMarking extension: \nP") - (or (listp extension) - (setq extension (list extension))) - (dired-mark-files-regexp - (concat ".";; don't match names with nothing but an extension - "\\(" - (mapconcat 'regexp-quote extension "\\|") - "\\)$") - marker-char)) - -(defun dired-flag-extension (extension) - "In dired, flag all files with a certain extension for deletion. -A `.' is *not* automatically prepended to the string entered." - (interactive "sFlagging extension: ") - (dired-mark-extension extension dired-del-marker)) - -(defvar patch-unclean-extensions - '(".rej" ".orig") - "List of extensions of dispensable files created by the `patch' program.") - -(defvar tex-unclean-extensions - '(".toc" ".log" ".aux");; these are already in completion-ignored-extensions - "List of extensions of dispensable files created by TeX.") - -(defvar latex-unclean-extensions - '(".idx" ".lof" ".lot" ".glo") - "List of extensions of dispensable files created by LaTeX.") - -(defvar bibtex-unclean-extensions - '(".blg" ".bbl") - "List of extensions of dispensable files created by BibTeX.") - -(defvar texinfo-unclean-extensions - '(".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" - ".tp" ".tps" ".vr" ".vrs") - "List of extensions of dispensable files created by texinfo.") - -(defun dired-clean-patch () - "Flag dispensable files created by patch for deletion. -See variable `patch-unclean-extensions'." - (interactive) - (dired-flag-extension patch-unclean-extensions)) - -(defun dired-clean-tex () - "Flag dispensable files created by tex etc. for deletion. -See variable `texinfo-unclean-extensions', `latex-unclean-extensions', -`bibtex-unclean-extensions' and `texinfo-unclean-extensions'." - (interactive) - (dired-flag-extension (append texinfo-unclean-extensions - latex-unclean-extensions - bibtex-unclean-extensions - tex-unclean-extensions))) - -(defun dired-do-unmark (unmarker) - "Unmark marked files by replacing the marker with another character. -The new character defaults to a space, effectively unmarking them." - (interactive "sChange marker to: ") - (if (string= unmarker "") - (setq unmarker " ")) - (setq unmarker (substring unmarker 0 1)) - (let ((regexp (dired-marker-regexp)) - (buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match unmarker))))) - -;; This is unused but might come in handy sometime -;(defun dired-directories-of (files) -; ;; Return unique list of parent directories of FILES. -; (let (dirs dir file) -; (while files -; (setq file (car files) -; files (cdr files) -; dir (file-name-directory file)) -; (or (member dir dirs) -; (setq dirs (cons dir dirs)))) -; dirs)) - -;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -;; Suggest you bind it to a key. I use C-x C-j. -(defun dired-jump-back (&optional other-window) - "Jump back to dired: -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." - (interactive) - (let* ((file buffer-file-name) - (dir (if file (file-name-directory file) default-directory))) - (if (eq major-mode 'dired-mode) - (progn - (setq dir (dired-current-directory)) - (if other-window - (dired-up-directory-other-window) - (dired-up-directory)) - (dired-really-goto-file dir)) - (if other-window - (dired-other-window dir) - (dired dir)) - (if file (dired-really-goto-file file))))) - -(defun dired-jump-back-other-window () - "Like \\[dired-jump-back], but to other window." - (interactive) - (dired-jump-back t)) - -(defun dired-really-goto-file (file) - (or (dired-goto-file file) - (progn ; refresh and try again - (dired-insert-subdir (file-name-directory file)) - (dired-goto-file file)))) - -(defun dired-up-directory-other-window () - "Like `dired-up-directory', but in other window." - (interactive) - (let* ((dir (dired-current-directory)) - (up (file-name-directory (directory-file-name dir)))) - (or (dired-goto-file (directory-file-name dir)) - (dired-goto-subdir up) - ;; Only in this case it really uses another window: - (progn - (dired-other-window up) - (dired-goto-file dir))))) - -(defun dired-mark-rcs-files (&optional unflag-p) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns failures, or nil on success. - ;; Finding those with locks would require to peek into the ,v file, - ;; depends slightly on the RCS version used and should be done - ;; together with the Emacs RCS interface. - ;; Unfortunately, there is no definitive RCS interface yet. - (interactive "P") - (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - (mapcar ; loop over subdirs - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (directory-files dir t ",v$") ; *,v and RCS/*,v - (let ((rcs-dir (expand-file-name "RCS" dir))) - (if (file-directory-p rcs-dir) - (mapcar ; working files from ./RCS are in ./ - (function - (lambda (x) - (expand-file-name x dir))) - (directory-files - (file-name-as-directory rcs-dir) nil ",v$")))) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (substring (car rcs-files) 0 -2) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark-file 1) - (setq failures (cons wf failures))))) - (if (null failures) - (message "%d RCS file%s %smarked." - total (dired-plural-s total) (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary "RCS working file not found %s" failures) - (message "%d RCS file%s: %d %smarked - %d not found %s." - total (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - -(defun dired-do-toggle () - "Toggle marks. -That is, currently marked files become unmarked and vice versa. -Files marked with other flags (such as `D') are not affected. -`.' and `..' are never toggled. -As always, hidden subdirs are not affected." - (interactive) - (save-excursion - (goto-char (point-min)) - (let (buffer-read-only) - (while (not (eobp)) - (or (dired-between-files) - (looking-at dired-re-dot) - ;; use subst instead of insdel because it does not move - ;; the gap and thus should be faster and because - ;; other characters are left alone automatically - (apply 'subst-char-in-region - (point) (1+ (point)) - (if (eq ?\040 (following-char)) ; SPC - (list ?\040 dired-marker-char) - (list dired-marker-char ?\040)))) - (forward-line 1))))) - -;; This function is missing in simple.el -(defun copy-string-as-kill (string) - "Save STRING as if killed in a buffer." - (setq kill-ring (cons string kill-ring)) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) - (setq kill-ring-yank-pointer kill-ring)) - -(defvar dired-marked-files nil - "List of filenames from last `dired-copy-filename-as-kill' call.") - -(defun dired-copy-filename-as-kill (&optional arg) - "Copy names of marked (or next ARG) files into the kill ring. -The names are separated by a space. -With a zero prefix arg, use the complete pathname of each marked file. -With a raw (just \\[universal-argument]) prefix arg, use the relative pathname of each marked file. - -If on a subdir headerline and no prefix arg given, use subdirname instead. - -You can then feed the file name to other commands with \\[yank]. - -The list of names is also stored onto the variable -`dired-marked-files' for use, e.g., in an `\\[eval-expression]' command." - (interactive "P") - (copy-string-as-kill - (or (and (not arg) - (dired-get-subdir)) - (mapconcat (function identity) - (setq dired-marked-files - (if arg - (cond ((zerop (prefix-numeric-value arg)) - (dired-mark-get-files)) - ((integerp arg) - (dired-mark-get-files 'no-dir arg)) - (t ; else a raw arg - (dired-mark-get-files t))) - (dired-mark-get-files 'no-dir))) - " "))) - (message "%s" (car kill-ring))) - -(defun dired-do-background-shell-command (&optional arg) - "Like \\[dired-do-shell-command], but starts command in background. -Note that you can type input to the command in its buffer. -This requires background.el from the comint package to work." - ;; With the version in emacs-19.el, you can alternatively just - ;; append an `&' to any shell command to make it run in the - ;; background, but you can't type input to it. - (interactive "P") - (dired-do-shell-command arg t)) - -;; redefines dired.el to put back in the dired-offer-kill-buffer -;; feature which rms didn't like. -(defun dired-clean-up-after-deletion (fn) - ;; Clean up after a deleted file or directory FN. - ;; Remove expanded subdir of deleted dir, if any - (save-excursion (and (dired-goto-subdir fn) - (dired-kill-subdir))) - ;; Offer to kill buffer of deleted file FN. - (let ((buf (get-file-buffer fn))) - (and buf - (funcall (function y-or-n-p) - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn))) - (save-excursion;; you never know where kill-buffer leaves you - (kill-buffer buf)))) - (let ((buf-list (dired-buffers-for-top-dir fn)) - (buf nil)) - (and buf-list - (y-or-n-p (format "Kill dired buffer%s of %s, too? " - (dired-plural-s (length buf-list)) - (file-name-nondirectory fn))) - (while buf-list - (save-excursion (kill-buffer (car buf-list))) - (setq buf-list (cdr buf-list))))) - ;; Anything else? - ) - -;;; Omitting - -;;; Enhanced omitting of lines from directory listings. -;;; Marked files are never omitted. -;;; Adapted from code submitted by: -;;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 - -(make-variable-buffer-local - (defvar dired-omit-files-p nil - "*If non-nil, \"uninteresting\" files are not listed (buffer-local). -Use \\[dired-omit-toggle] to toggle its value. -Uninteresting files are those whose filenames match regexp `dired-omit-files', -plus those ending with extensions in `dired-omit-extensions'.")) - -(defvar dired-omit-files "^#\\|\\.$" - "*Filenames matching this regexp will not be displayed (buffer-local). -This only has effect when `dired-omit-files-p' is t. -See also `dired-omit-extensions'.") - -(defvar dired-omit-extensions - (append completion-ignored-extensions - latex-unclean-extensions - bibtex-unclean-extensions - texinfo-unclean-extensions) - "*If non-nil, a list of extensions (strings) to omit from Dired -listings. Defaults to the elements of -`completion-ignored-extensions', `latex-unclean-extensions', -`bibtex-unclean-extensions' and `texinfo-unclean-extensions'.") - -;; should probably get rid of this and always use 'no-dir. -;; sk 28-Aug-1991 09:37 -(defvar dired-omit-localp 'no-dir - "The LOCALP argument dired-omit-expunge passes to dired-get-filename. -If it is 'no-dir, omitting is much faster, but you can only match -against the basename of the file. Set it to nil if you need to match the -whole pathname.") - -;; \017=^O for Omit - other packages can chose other control characters. -(defvar dired-omit-marker-char ?\017 - "Temporary marker used by dired-omit. -Should never be used as a marker by the user or other packages.") - -(defun dired-omit-startup () - (or (assq 'dired-omit-files-p minor-mode-alist) - ;; Append at end so that it doesn't get between "Dired" and "by name". - (setq minor-mode-alist - (append minor-mode-alist '((dired-omit-files-p " Omit")))))) - -(defun dired-omit-toggle (&optional flag) - "Toggle between displaying and omitting files matching `dired-omit-files'. -With an arg, and if omitting was off, don't toggle and just mark the - files but don't actually omit them. -With an arg, and if omitting was on, turn it off but don't refresh the buffer." - (interactive "P") - (if flag - (if dired-omit-files-p - (setq dired-omit-files-p (not dired-omit-files-p)) - (dired-mark-unmarked-files (dired-omit-regexp) nil nil - dired-omit-localp)) - ;; no FLAG - (setq dired-omit-files-p (not dired-omit-files-p)) - (if (not dired-omit-files-p) - (revert-buffer) - ;; this will mention how many were omitted: - (dired-omit-expunge)))) - -;; This is sometimes let-bound to t if messages would be annoying, -;; e.g., in dired-awrh.el. -(defvar dired-omit-silent nil) - -;; in emacs19 `(dired-do-kill)' is called `(dired-do-kill-lines)' -(if (fboundp 'dired-do-kill-lines) - (fset 'dired-do-kill 'dired-do-kill-lines)) - -(defun dired-omit-expunge (&optional regexp) - "Erases all unmarked files matching REGEXP. -Does nothing if global variable `dired-omit-files-p' is nil. -If REGEXP is nil or not specified, uses `dired-omit-files', and also omits - filenames ending in `dired-omit-extensions'. -If REGEXP is the empty string, this function is a no-op. - -This functions works by temporarily binding `dired-marker-char' to -`dired-omit-marker-char' and calling `dired-do-kill'." - (interactive "sOmit files (regexp): ") - (if dired-omit-files-p - (let ((omit-re (or regexp (dired-omit-regexp))) - count) - (or (string= omit-re "") - (let ((dired-marker-char dired-omit-marker-char)) - (or dired-omit-silent (message "Omitting...")) - (if (dired-mark-unmarked-files - omit-re nil nil dired-omit-localp) - (setq count (dired-do-kill nil (if dired-omit-silent - "" - "Omitted %d line%s."))) - (or dired-omit-silent - (message "(Nothing to omit)"))))) - count))) - -(defun dired-omit-regexp () - (concat (if dired-omit-files (concat "\\(" dired-omit-files "\\)") "") - (if (and dired-omit-files dired-omit-extensions) "\\|" "") - (if dired-omit-extensions - (concat ".";; a non-extension part should exist - "\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)$") - ""))) - -;; Returns t if any work was done, nil otherwise. -(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) - "Marks unmarked files matching REGEXP, displaying MSG. -REGEXP is matched against the complete pathname. -Does not re-mark files which already have a mark. -With prefix argument, unflag all those files. -Second optional argument LOCALP is as in `dired-get-filename'." - (interactive "P") - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char))) - (dired-mark-if - (and - ;; not already marked - (looking-at " ") - ;; uninteresting - (let ((fn (dired-get-filename localp t))) - (and fn (string-match regexp fn)))) - msg))) - -(defun dired-omit-new-add-entry (filename &optional marker-char) - ;; This redefines dired.el's dired-add-entry to avoid calling ls for - ;; files that are going to be omitted anyway. - (if dired-omit-files-p - ;; perhaps return t without calling ls - (let ((omit-re (dired-omit-regexp))) - (if (or (string= omit-re "") - (not - (string-match omit-re - (cond - ((eq 'no-dir dired-omit-localp) - filename) - ((eq t dired-omit-localp) - (dired-make-relative filename)) - (t - (dired-make-absolute filename directory)))))) - ;; if it didn't match, go ahead and add the entry - (dired-omit-old-add-entry filename marker-char) - ;; dired-add-entry returns t for success, perhaps we should - ;; return file-exists-p - t)) - ;; omitting is not turned on at all - (dired-omit-old-add-entry filename marker-char))) - -;; Save old defun if not already done: -(or (fboundp 'dired-omit-old-add-entry) - (fset 'dired-omit-old-add-entry (symbol-function 'dired-add-entry))) -;; Redefine dired.el -(fset 'dired-add-entry 'dired-omit-new-add-entry) - - -;; -(defun dired-mark-sexp (predicate &optional unflag-p) - "Mark files for which PREDICATE returns non-nil. -With a prefix arg, unflag those files instead. - -PREDICATE is a lisp expression that can refer to the following symbols: - - inode [integer] the inode of the file (only for ls -i output) - s [integer] the size of the file for ls -s output - (ususally in blocks or, with -k, in KByte) - mode [string] file permission bits, e.g. \"-rw-r--r--\" - nlink [integer] number of links to file - uid [string] owner - gid [string] group (If the gid is not displayed by ls, - this will still be set (to the same as uid)) - size [integer] file size in bytes - time [string] the time that ls displays, e.g. \"Feb 12 14:17\" - name [string] the name of the file - sym [string] if file is a symbolic link, the linked-to name, else \"\" - -For example, use - - (equal 0 size) - -to mark all zero length files." - ;; Using sym="" instead of nil avoids the trap of - ;; (string-match "foo" sym) into which a user would soon fall. - ;; Give `equal' instead of `=' in the example, as this works on - ;; integers and strings. - (interactive "xMark if (lisp expr): \nP") - (message "%s" predicate) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) - inode s mode nlink uid gid size time name sym) - (dired-mark-if - (save-excursion (and (dired-parse-ls) - (eval predicate))) - (format "'%s file" predicate)) - ;; With Jamie's compiler we could do the following instead: -; (eval (byte-compile-sexp -; (macroexpand -; (` (dired-mark-if -; (save-excursion (and (dired-parse-ls) -; (, predicate))) -; (format "'%s file" (quote (, predicate)))))))) - ;; This isn't measurably faster, though, at least for simple predicates. - ;; Caching compiled predicates might be interesting if you use - ;; this command a lot or with complicated predicates. - ;; Alternatively compiling PREDICATE by hand should not be too - ;; hard - e.g., if it uses just one variable, not all of the ls - ;; line needs to be parsed. - )) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-mark-sexp 'eval-expression-history)) - -(defun dired-parse-ls () - ;; Sets vars - ;; inode s mode nlink uid gid size time name sym - ;; (probably let-bound in caller) according to current file line. - ;; Returns t for succes, nil if this is no file line. - ;; Upon success, all variables are set, either to nil or the - ;; appropriate value, so they need not be initialized. - ;; Moves point within the current line. - (if (dired-move-to-filename) - (let (pos - (mode-len 10) ; length of mode string - ;; like in dired.el, but with subexpressions \1=inode, \2=s: - (dired-re-inode-size "\\s *\\([0-9]*\\)\\s *\\([0-9]*\\) ?")) - (beginning-of-line) - (forward-char 2) - (if (looking-at dired-re-inode-size) - (progn - (goto-char (match-end 0)) - (setq inode (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))) - s (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))))) - (setq inode nil - s nil)) - (setq mode (buffer-substring (point) (+ mode-len (point)))) - (forward-char mode-len) - (setq nlink (read (current-buffer))) - (setq uid (buffer-substring (point) (progn (forward-word 1) (point)))) - (re-search-forward "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)") - (goto-char (match-beginning 1)) - (forward-char -1) - (setq size (string-to-int (buffer-substring (save-excursion - (backward-word 1) - (setq pos (point))) - (point)))) - (goto-char pos) - (backward-word 1) - ;; if no gid is displayed, gid will be set to uid - ;; but user will then not reference it anyway in PREDICATE. - (setq gid (buffer-substring (save-excursion (forward-word 1) (point)) - (point)) - time (buffer-substring (match-beginning 1) - (1- (dired-move-to-filename))) - name (buffer-substring (point) - (or (dired-move-to-end-of-filename t) - (point))) - sym (progn - (if (looking-at " -> ") - (buffer-substring (progn (forward-char 4) (point)) - (progn (end-of-line) (point))) - ""))) - t) - nil)) - - -;; tester -;;(defun dired-parse-ls-show () -;; (interactive) -;; (let (inode s mode size uid gid nlink time name sym) -;; (if (dired-parse-ls) -;; (message "%s" (list inode s mode nlink uid gid size time name sym)) -;; (message "Not on a file line.")))) - - -;; Mark files whose names appear in another buffer. - -(defun dired-mark-these-files (file-list from) - ;; Mark the files in FILE-LIST. Relative filenames are taken to be - ;; in the current dired directory. - ;; FROM is a string (used for logging) describing where FILE-LIST - ;; came from. - ;; Logs files that were not found and displays a success or failure - ;; message. - (message "Marking files %s..." from) - (let ((total (length file-list)) - (cur-dir (dired-current-directory)) - file failures) - (while file-list - (setq file (dired-make-absolute (car file-list) cur-dir) - file-list (cdr file-list)) - ;;(message "Marking file `%s'" file) - (save-excursion - (if (dired-goto-file file) - (dired-mark-file 1) - (setq failures (cons (dired-make-relative file) failures)) - (dired-log "Cannot mark this file (not found): %s\n" file)))) - (if failures - (dired-log-summary (message "Failed to mark %d of %d files %s %s" - (length failures) total from failures)) - (message "Marked %d file%s %s." total (dired-plural-s total) from)))) - -(defun dired-mark-files-from-other-dired-buffer (buf) - "Mark files that are marked in the other Dired buffer. -I.e, mark those files in this Dired buffer that have the same -non-directory part as the marked files in the Dired buffer in the other window." - (interactive (list (window-buffer (next-window)))) - (if (eq (get-buffer buf) (current-buffer)) - (error "Other dired buffer is the same")) - (or (stringp buf) (setq buf (buffer-name buf))) - (let ((other-files (save-excursion - (set-buffer buf) - (or (eq major-mode 'dired-mode) - (error "%s is not a dired buffer" buf)) - (dired-mark-get-files 'no-dir)))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - -(defun dired-mark-files-compilation-buffer (&optional regexp buf) - "Mark the files mentioned in the `*compilation*' buffer. -With an arg, you may specify the other buffer and your own regexp -instead of `compilation-error-regexp'. -Use `^.+$' (the default with a prefix arg) to match complete lines or -an empty string for `compilation-error-regexp'. -In conjunction with narrowing the other buffer you can mark an -arbitrary list of files, one per line, with this command." - (interactive - (if current-prefix-arg - (list - (read-string "Use compilation regexp: " "^.+$") - (read-buffer "Use buffer: " - (let ((next-buffer (window-buffer (next-window)))) - (if (eq next-buffer (current-buffer)) - (other-buffer) - next-buffer)))))) - (let (other-files user-regexp-p) - (if (zerop (length regexp)) ; nil or "" - (setq regexp compilation-error-regexp) - (setq user-regexp-p t)) - (or buf (setq buf "*compilation*")) - (or (stringp buf) (setq buf (buffer-name buf))) - (save-excursion - (set-buffer (or (get-buffer buf) - (error "No %s buffer!" buf))) - (goto-char (point-min)) - (let (file new-file) - (while (re-search-forward regexp nil t) - (setq new-file - (buffer-substring - ;; If user specified a regexp with subexpr 1, and it - ;; matched, take that one for the file name, else - ;; take whole match. - ;; Else take the match from the compile regexp - (if user-regexp-p - (or (match-beginning 1) - (match-beginning 0)) - (match-beginning 1)) - (if user-regexp-p - (or (match-end 1) - (match-end 0)) - (match-beginning 2)))) - (or (equal file new-file) - ;; Avoid marking files twice as this is slow. Multiple - ;; lines for the same file are common when compiling. - (setq other-files (cons new-file other-files) - file new-file))))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - - -;; make-symbolic-link always expand-file-name's its args, so relative -;; symlinks (e.g. "foo" -> "../bar/foo") are impossible to create. -;; Following code uses ln -s for a workaround. - -(defvar dired-keep-marker-relsymlink ?S - "See variable `dired-keep-marker-move'.") - -(defun dired-make-symbolic-link (name1 name2 &optional ok-if-already-exists) - ;; Args NAME1 NAME2 &optional OK-IF-ALREADY-EXISTS. - ;; Create file NAME2, a symbolic link pointing to NAME1 (which may - ;; be any string whatsoever and is passed untouched to ln -s). - ;; OK-IF-ALREADY-EXISTS means that NAME2 will be overwritten if it - ;; already exists. If it is an integer, user will be asked about this. - ;; On error, signals a file-error. - (interactive "FSymlink to (string): \nFMake symbolic link to `%s': \np") - (setq name2 (expand-file-name name2)) - (let* ((file-symlink-p (file-symlink-p name2)) - (file-exists-p (file-exists-p name2)) ; dereferences symlinks - (file-or-symlink-exists (or file-symlink-p file-exists-p))) - (if (and file-symlink-p (not file-exists-p)) - ;; We do something dirty here as dired.el never checks - ;; file-symlink-p in addition to file-exists-p. - ;; This way me make sure we never silently overwrite even - ;; symlinks to non-existing files (what an achievement! ;-) - (setq ok-if-already-exists 1)) - (if (or (null ok-if-already-exists) - (integerp ok-if-already-exists)) - (if (and file-or-symlink-exists - (not (and (integerp ok-if-already-exists) - (yes-or-no-p - (format - "File %s already exists; symlink anyway? " - name2))))) - (signal 'file-error (cons "File already exists" name2)))) - ;; Bombs if NAME1 starts with "-", but not all ln programs may - ;; understand "--" to mean end of options...sigh - (let (err) - (if file-or-symlink-exists (delete-file name2)) - (setq err (dired-check-process "SymLink" "ln" "-s" name1 name2)) - (if err - (signal 'file-error (cons "ln" err)))))) - -(defun dired-make-relative-symlink (file1 file2 &optional ok-if-already-exists) - "Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS -Make a symbolic link (pointing to FILE1) in FILE2. -The link is relative (if possible), for example - - \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" - -results in - - \"../../tex/bin/foo\" \"/vol/local/bin/foo\" -" - (interactive "FRelSymLink: \nFRelSymLink %s: \np") - (let (name1 name2 len1 len2 (index 0) sub) - (setq file1 (expand-file-name file1) - file2 (expand-file-name file2) - len1 (length file1) - len2 (length file2)) - ;; Find common initial pathname components: - (let (next) - (while (and (setq next (string-match "/" file1 index)) - (setq next (1+ next)) - (< next (min len1 len2)) - ;; For the comparison, both substrings must end in - ;; `/', so NEXT is *one plus* the result of the - ;; string-match. - ;; E.g., consider the case of linking "/tmp/a/abc" - ;; to "/tmp/abc" erronously giving "/tmp/a" instead - ;; of "/tmp/" as common initial component - (string-equal (substring file1 0 next) - (substring file2 0 next))) - (setq index next)) - (setq name2 file2 - sub (substring file1 0 index) - name1 (substring file1 index))) - (if (string-equal sub "/") - ;; No common initial pathname found - (setq name1 file1) - ;; Else they have a common parent directory - (let ((tem (substring file2 index)) - (start 0) - (count 0)) - ;; Count number of slashes we must compensate for ... - (while (setq start (string-match "/" tem start)) - (setq count (1+ count) - start (1+ start))) - ;; ... and prepend a "../" for each slash found: - (while (> count 0) - (setq count (1- count) - name1 (concat "../" name1))))) - (dired-make-symbolic-link - (directory-file-name name1) ; must not link to foo/ - ; (trailing slash!) - name2 ok-if-already-exists))) - -(defun dired-do-relsymlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file. -This creates relative symbolic links like - - foo -> ../bar/foo - -not absolute ones like - - foo -> /ugly/path/that/may/change/any/day/bar/foo" - (interactive "P") - (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) - "RelSymLink" arg dired-keep-marker-relsymlink)) - -;; XEmacs: added extra arg per tbarker@sun059.cpdsc.com (Ted Barker) -(defun dired-do-relsymlink-regexp (regexp newname &optional arg whole-path) - "RelSymlink all marked files containing REGEXP to NEWNAME. -See functions `dired-rename-regexp' and `dired-do-relsymlink' - for more info. With optional prefix ARG, will operate on ARG files following -point if no files are marked." - (interactive (dired-mark-read-regexp "RelSymLink")) - (dired-do-create-files-regexp - (function dired-make-relative-symlink) - "RelSymLink" arg regexp newname whole-path dired-keep-marker-relsymlink)) - -;; Virtual dired mode to browse ls -lR listings -;; sk@sun5 7-Mar-1991 16:00 - -(fset 'virtual-dired 'dired-virtual) -(defun dired-virtual (dirname &optional switches) - "Put this buffer into Virtual Dired mode. - -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. - -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -ange-ftp, you can even dired a directory containing an ls-lR file, -visit that file and turn on virtual dired mode. But don't try to save -this file, as dired-virtual indents the listing and thus changes the -buffer. - -If you have save a Dired buffer in a file you can use \\[dired-virtual] to -resume it in a later session. - -Type \\\\[revert-buffer] in the -Virtual Dired buffer and answer `y' to convert the virtual to a real -dired buffer again. You don't have to do this, though: you can relist -single subdirs using \\[dired-do-redisplay]. -" - - ;; DIRNAME is the top level directory of the buffer. It will become - ;; its `default-directory'. If nil, the old value of - ;; default-directory is used. - - ;; Optional SWITCHES are the ls switches to use. - - ;; Shell wildcards will be used if there already is a `wildcard' - ;; line in the buffer (thus it is a saved Dired buffer), but there - ;; is no other way to get wildcards. Insert a `wildcard' line by - ;; hand if you want them. - - (interactive - (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) - (goto-char (point-min)) - (or (looking-at " ") - ;; if not already indented, do it now: - (indent-region (point-min) (point-max) 2)) - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name (file-name-as-directory dirname))) - (setq default-directory dirname) ; contains no wildcards - (let ((wildcard (save-excursion - (goto-char (point-min)) - (forward-line 1) - (and (looking-at "^ wildcard ") - (buffer-substring (match-end 0) - (progn (end-of-line) (point))))))) - (if wildcard - (setq dirname (expand-file-name wildcard default-directory)))) - ;; If raw ls listing (not a saved old dired buffer), give it a - ;; decent subdir headerline: - (goto-char (point-min)) - (or (looking-at dired-subdir-regexp) - (dired-insert-headerline default-directory)) - (dired-mode dirname (or switches dired-listing-switches)) - (setq mode-name "Virtual Dired" - revert-buffer-function 'dired-virtual-revert) - (set (make-local-variable 'dired-subdir-alist) nil) - (dired-build-subdir-alist) - (goto-char (point-min)) - (dired-initial-position dirname)) - -(defun dired-virtual-guess-dir () - - ;; Guess and return appropriate working directory of this buffer, - ;; assumed to be in Dired or ls -lR format. - ;; The guess is based upon buffer contents. - ;; If nothing could be guessed, returns nil. - - (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") - (subexpr 2)) - (goto-char (point-min)) - (cond ((looking-at regexp) - ;; If a saved dired buffer, look to which dir and - ;; perhaps wildcard it belongs: - (let ((dir (buffer-substring (match-beginning subexpr) - (match-end subexpr)))) - (file-name-as-directory dir))) - ;; Else no match for headerline found. It's a raw ls listing. - ;; In raw ls listings the directory does not have a headerline - ;; try parent of first subdir, if any - ((re-search-forward regexp nil t) - (file-name-directory - (directory-file-name - (file-name-as-directory - (buffer-substring (match-beginning subexpr) - (match-end subexpr)))))) - (t ; if all else fails - nil)))) - - -(defun dired-virtual-revert (&optional arg noconfirm) - (if (not - (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) - (error "Cannot revert a Virtual Dired buffer.") - (setq mode-name "Dired" - revert-buffer-function 'dired-revert) - (revert-buffer))) - -;; A zero-arg version of dired-virtual. -;; You need my modified version of set-auto-mode for the -;; `buffer-contents-mode-alist'. -;; Or you use infer-mode.el and infer-mode-alist, same syntax. -(defun dired-virtual-mode () - "Put current buffer into virtual dired mode (see `dired-virtual'). -Useful on `buffer-contents-mode-alist' (which see) with the regexp - - \"^ \\(/[^ /]+\\)/?+:$\" - -to put saved dired buffers automatically into virtual dired mode. - -Also useful for `auto-mode-alist' (which see) like this: - - \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) - auto-mode-alist)\) -" - (interactive) - (dired-virtual (dired-virtual-guess-dir))) - - -(defvar dired-find-subdir nil ; t is pretty near to DWIM... - "*If non-nil, Dired does not make a new buffer for a directory if it -can be found (perhaps as subdir) in some existing Dired buffer. - -If there are several Dired buffers for a directory, the most recently -used is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -(or (fboundp 'dired-old-find-buffer-nocreate) - (fset 'dired-old-find-buffer-nocreate - (symbol-function 'dired-find-buffer-nocreate))) - -(defun dired-find-buffer-nocreate (dirname) ; redefine dired.el - (if dired-find-subdir - (let* ((cur-buf (current-buffer)) - (buffers (nreverse (dired-buffers-for-dir-exact dirname))) - (cur-buf-matches (and (memq cur-buf buffers) - ;; wildcards must match, too: - (equal dired-directory dirname)))) - ;; We don't want to switch to the same buffer--- - (setq buffers (delq cur-buf buffers));;need setq with delq - (or (car (sort buffers (function dired-x-buffer-more-recently-used-p))) - ;; ---unless it's the only possibility: - (and cur-buf-matches cur-buf))) - (dired-old-find-buffer-nocreate dirname))) - -;; this should be a builtin -(defun dired-x-buffer-more-recently-used-p (buffer1 buffer2) - "Return t if BUFFER1 is more recently used than BUFFER2." - (if (equal buffer1 buffer2) - nil - (let ((more-recent nil) - (list (buffer-list))) - (while (and list - (not (setq more-recent (equal buffer1 (car list)))) - (not (equal buffer2 (car list)))) - (setq list (cdr list))) - more-recent))) - -(defun dired-buffers-for-dir-exact (dir) -;; Return a list of buffers that dired DIR (a directory or wildcard) -;; at top level, or as subdirectory. -;; Top level matches must match the wildcard part too, if any. -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - ;; Top level must match exactly against dired-directory in - ;; case one of them is a wildcard. - (if (or (equal dir (save-excursion (set-buffer buf) - dired-directory)) - (assoc dir (save-excursion (set-buffer buf) - dired-subdir-alist))) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - result)) - -(defun dired-buffers-for-top-dir (dir) -;; Return a list of buffers that dired DIR (a directory, not a wildcard) -;; at top level, with or without wildcards. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (equal dir (save-excursion (set-buffer buf) default-directory)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - result)) - -(defun dired-initial-position (dirname) ; redefine dired.el - (end-of-line) - (if dired-find-subdir (dired-goto-subdir dirname)) ; new - (if dired-trivial-filenames (dired-goto-next-nontrivial-file))) - -;;; Let `C-x f' and `C-x 4 f' know about Tree Dired's multiple directories. -;;; As a bonus, you get filename-at-point as default with a prefix arg. - -;; It's easier to add to this alist than redefine function -;; default-directory while keeping the old information. -(defconst default-directory-alist - '((dired-mode . (if (fboundp 'dired-current-directory) - (dired-current-directory) - default-directory))) - "Alist of major modes and their opinion on default-directory, as a -lisp expression to evaluate. A resulting value of nil is ignored in -favor of default-directory.") - -(defun default-directory () - "Usage like variable `default-directory', but knows about the special -cases in variable `default-directory-alist' (which see)." - (or (eval (cdr (assq major-mode default-directory-alist))) - default-directory)) - -(defun find-file-read-filename-at-point (prompt) - (if (fboundp 'gmhist-read-file-name) - (if current-prefix-arg - (let ((fn (filename-at-point))) - (gmhist-read-file-name - prompt (default-directory) fn nil - ;; the INITIAL arg is only accepted in Emacs 19 or with gmhist: - fn)) - (gmhist-read-file-name prompt (default-directory))) - ;; Else gmhist is not available, thus no initial input possible. - ;; Could use filename-at-point as default and mung prompt...ugh. - ;; Nah, get gmhist, folks! - (read-file-name prompt (default-directory)))) - -(defun filename-at-point () - "Get the filename closest to point, but don't change your position. -Has a preference for looking backward when not directly on a symbol." - ;; Not at all perfect - point must be right in the name. - (let ((filename-chars ".a-zA-Z0-9---_/:$") start end filename - (bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point)))) - (save-excursion - ;; first see if you're just past a filename - (if (not (eobp)) - (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens - (progn - (skip-chars-backward " \n\t\r({[]})") - (if (not (bobp)) - (backward-char 1))))) - (if (string-match (concat "[" filename-chars "]") - (char-to-string (following-char))) - (progn - (skip-chars-backward filename-chars) - (setq start (point)) - (if (string-match "[/~]" (char-to-string (preceding-char))) - (setq start (1- start))) - (skip-chars-forward filename-chars)) - (error "No file found around point!")) - (expand-file-name (buffer-substring start (point)))))) - -(defun find-this-file (fn) - "Edit file FILENAME. -Switch to a buffer visiting file FILENAME, creating one if none already exists. - -Interactively, with a prefix arg, calls `filename-at-point'. -Useful to edit the file mentioned in the buffer you are editing, or to -test if that file exists: use minibuffer completion after snatching the -name or part of it." - (interactive (list (find-file-read-filename-at-point "Find file: "))) - (find-file (expand-file-name fn))) - -(defun find-this-file-other-window (fn) - "Edit file FILENAME in other window. -Switch to a buffer visiting file FILENAME, creating one if none already exists. - -Interactively, with a prefix arg, call `filename-at-point'. -Useful to edit the file mentioned in the buffer you are editing, or to -test if that file exists: use minibuffer completion after snatching the -name or part of it." - (interactive (list (find-file-read-filename-at-point "Find file: "))) - (find-file-other-window (expand-file-name fn))) - -(defun dired-smart-shell-command (cmd &optional insert) - "Like function `shell-command', but in the current Tree Dired directory." - (interactive "sShell command: \nP") - (let ((default-directory (default-directory))) - (shell-command cmd insert))) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-smart-shell-command 'shell-history)) - -(defun dired-smart-background-shell-command (cmd) - "Run a shell command in the background. -Like function `background' but in the current Tree Dired directory." - (interactive "s%% ") - (shell-command (concat "cd " (default-directory) "; " cmd " &"))) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-smart-background-shell-command 'shell-history)) - - -;; Local variables for Dired buffers - -(defvar dired-local-variables-file ".dired" - "If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -(defun dired-hack-local-variables () - "Parse, and bind or evaluate as appropriate, any local variables -for current dired buffer. -See variable `dired-local-variables-file'." - (if (and dired-local-variables-file - (file-exists-p dired-local-variables-file)) - (let (buffer-read-only opoint ) - (save-excursion - (goto-char (point-max)) - (setq opoint (point-marker)) - (insert "\^L\n") - (insert-file-contents dired-local-variables-file)) - (let ((buffer-file-name dired-local-variables-file)) - (hack-local-variables)) - ;; Must delete it as (eobp) is often used as test for last - ;; subdir in dired.el. - (delete-region opoint (point-max)) - (set-marker opoint nil)))) - -;; Guess what shell command to apply to a file. - -(defvar dired-guess-have-gnutar nil - "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -(defvar dired-make-gzip-quiet t - "*If non-nil, pass -q to shell commands involving gzip this will override -GZIP environment variable.") - -(defvar dired-znew-switches nil - "*If non-nil, a string of switches that will be passed to `znew' -example: \"-K\"") - -(defvar dired-auto-shell-command-alist-default - (list - (list "\\.tar$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " xvf") - "tar xvf")) - - ;; regexps for compressed archives must come before the .Z rule to - ;; be recognized: - (list "\\.tar\\.Z$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " zxvf") - (concat "zcat * | tar xvf -")) - ;; optional conversion to gzip (GNU zip) format - (concat "znew" - (if dired-make-gzip-quiet " -q") - " " dired-znew-switches)) - - ;; gzip'ed (GNU zip) archives - (list "\\.tar\\.g?z$\\|\\.tgz$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " zxvf") - ;; use `gunzip -qc' instead of `zcat' since some - ;; people don't install GNU zip's version of zcat - (concat "gunzip -qc * | tar xvf -"))) - '("\\.shar.Z$" "zcat * | unshar") - ;; use `gunzip -c' instead of `zcat' - '("\\.shar.g?z$" "gunzip -qc * | unshar") - '("\\.ps$" "ghostview" "xv" "lpr") - '("\\.ps.g?z$" "gunzip -qc * | ghostview -" - ;; optional decompression - (concat "gunzip" (if dired-make-gzip-quiet " -q"))) - '("\\.ps.Z$" "zcat * | ghostview -" - ;; optional conversion to gzip (GNU zip) format - (concat "znew" - (if dired-make-gzip-quiet " -q") - " " dired-znew-switches)) - '("\\.dvi$" "xdvi" "dvips") - '("\\.au$" "play") ; play Sun audiofiles - '("\\.mpg$" "mpeg_play") - '("\\.dl$" "xdl") ; loop pictures - '("\\.fli$" "xanim") - '("\\.gl$" "xgrasp") - '("\\.uu$" "uudecode") - '("\\.hqx$" "mcvert") - '("\\.sh$" "sh") ; execute shell scripts - '("\\.xbm$" "bitmap") ; view X11 bitmaps - '("\\.xpm$" "sxpm") - '("\\.gp$" "gnuplot") - '("\\.p[bgpn]m$" "xv") - '("\\.gif$" "xv") ; view gif pictures - '("\\.tif$" "xv") - '("\\.jpg$" "xv") - '("\\.fig$" "xfig") ; edit fig pictures - '("\.tex$" "latex" "tex") - '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") - (if (eq window-system 'x) ; under X, offer both... - '("\\.dvi$" "xtex" "dvips") ; ...preview and printing - '("\\.dvi$" "dvips")) - '("\\.g?z$" (concat "gunzip" (if dired-make-gzip-quiet " -q" ""))) ; quiet? - '("\\.Z$" "uncompress" - ;; optional conversion to gzip (GNU zip) format - (concat "znew" (if dired-make-gzip-quiet " -q") " " dired-znew-switches)) - ;; some popular archivers: - '("\\.zoo$" "zoo x//") - '("\\.zip$" "unzip") - '("\\.lzh$" "lharc x") - '("\\.arc$" "arc x") - '("\\.shar$" "unshar") ; use "sh" if you don't have unshar - ) - - "Default for variable `dired-auto-shell-command-alist' (which see). -Set this to nil to turn off shell command guessing.") - -(defvar dired-auto-shell-command-alist nil - "*If non-nil, an alist of file regexps and their suggested commands. -Dired shell commands will look up the name of a file in this list -and suggest the matching command as default. - -Each element of this list looks like - - \(REGEXP COMMAND...\) - -where each COMMAND can either be a string or a lisp expression that -evaluates to a string. If several COMMANDs are given, the first one -will be the default and minibuffer completion will use the given set. - -These rules take precedence over the predefined rules in the variable -`dired-auto-shell-command-alist-default' (to which they are prepended). - -You can set this variable in your ~/.emacs. For example, to add -rules for `.foo' and `.bar' files, write - -\(setq dired-auto-shell-command-alist - (list (list \"\\\\.foo$\" \"FOO-COMMAND\");; fixed rule - ;; possibly more rules ... - (list \"\\\\.bar$\";; rule with condition test - '(if condition - \"BAR-COMMAND-1\" - \"BAR-COMMAND-2\")))\) -") - -(setq dired-auto-shell-command-alist - (if dired-auto-shell-command-alist;; join user and default value: - (append dired-auto-shell-command-alist - dired-auto-shell-command-alist-default) - ;; else just copy the default value: - dired-auto-shell-command-alist-default)) - -(defun dired-guess-default (files) - ;; Guess a shell command for FILES. - ;; Returns a command or a list of commands. - ;; You may want to redefine this to try something smarter. - (if (or (cdr files) - (null dired-auto-shell-command-alist)) - nil ; If more than one file, don't guess - (let* ((file (car files)) - (alist dired-auto-shell-command-alist) - (case-fold-search nil) ; need search to be case-sensitive in order - ; to distinguish between gzip'ed (`.z') and - ; compressed (`.Z') files - elt re cmds) - (while alist - (setq elt (car alist) - re (car elt) - alist (cdr alist)) - (if (string-match re file) - (setq cmds (cdr elt) - alist nil))) - (cond ((not (cdr cmds)) (eval (car cmds))) ; single command - (t (mapcar (function eval) cmds)))))) - -(defun dired-guess-shell-command (prompt files) - ;;"Ask user with PROMPT for a shell command, guessing a default from FILES." - (let ((default (dired-guess-default files)) - default-list old-history val (failed t)) - (if (not (featurep 'gmhist)) - (read-string prompt (if (listp default) (car default) default)) - ;; else we have gmhist - (if (null default) - (read-with-history-in 'dired-shell-command-history prompt) - (or (boundp 'dired-shell-command-history) - (setq dired-shell-command-history nil)) - (setq old-history dired-shell-command-history) - (if (listp default) - ;; more than one guess - (setq default-list default - default (car default) - prompt (concat - prompt - (format "{%d guesses} " (length default-list)))) - ;; just one guess - (setq default-list (list default))) - (put 'dired-shell-command-history 'default default) - ;; push guesses onto history so that they can be retrieved with M-p - (setq dired-shell-command-history - (append default-list dired-shell-command-history)) - ;; the unwind-protect returns VAL, and we too. - (unwind-protect - (progn - (setq val (read-with-history-in - 'dired-shell-command-history prompt) - failed nil) - val) - (progn - ;; Undo pushing onto the history list so that an aborted - ;; command doesn't get the default in the next command. - (setq dired-shell-command-history old-history) - (if (not failed) - (or (equal val (car-safe dired-shell-command-history)) - (setq dired-shell-command-history - (cons val dired-shell-command-history)))))))))) - -;; redefine dired.el's version: -(defun dired-read-shell-command (prompt arg files) - "Read a dired shell command using generic minibuffer history. -This command tries to guess a command from the filename(s) -from the variable `dired-auto-shell-command-alist' (which see)." - (dired-mark-pop-up - nil 'shell files ; bufname type files - 'dired-guess-shell-command ; function &rest args - (format prompt (dired-mark-prompt arg files)) files)) - - -;; Byte-compile-and-load (requires jwz@lucid.com's new byte compiler) -(defun dired-do-byte-compile-and-load (&optional arg) - "Byte compile marked and load (or next ARG) Emacs lisp files. -This requires jwz@lucid.com's new optimizing byte compiler." - (interactive "P") - (dired-mark-map-check (function dired-byte-compile-and-load) arg - 'byte-compile-and-load t)) - -(defun dired-byte-compile-and-load () - ;; Return nil for success, offending file name else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (new-file (byte-compile-dest-file from-file))) - (if (not (string-match elisp-source-extention-re from-file)) - (progn - (dired-log "Attempt to compile non-elisp file %s\n" from-file) - ;; return a non-nil value as error indication - (dired-make-relative from-file)) - (save-excursion;; Jamie's compiler may switch buffer - (byte-compile-and-load-file from-file)) - (dired-remove-file new-file) - (forward-line) ; insert .elc after its .el file - (dired-add-file new-file) - nil))) - -;; Visit all marked files simultaneously. -;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). - -(defun dired-do-find-file (&optional arg) - "Visit all marked files at once, and display them simultaneously. -See also function `simultaneous-find-file'. -If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. -If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." - (interactive "P") - (simultaneous-find-file (dired-mark-get-files nil arg))) - -(defun simultaneous-find-file (file-list) - "Visit all files in FILE-LIST and display them simultaneously. - -The current window is split across all files in FILE-LIST, as evenly -as possible. Remaining lines go to the bottommost window. - -The number of files that can be displayed this way is restricted by -the height of the current window and the variable `window-min-height'." - ;; It is usually too clumsy to specify FILE-LIST interactively - ;; unless via dired (dired-do-find-file). - (let ((size (/ (window-height) (length file-list)))) - (or (<= window-min-height size) - (error "Too many files to visit simultaneously")) - (find-file (car file-list)) - (setq file-list (cdr file-list)) - (while file-list - ;; Split off vertically a window of the desired size - ;; The upper window will have SIZE lines. We select the lower - ;; (larger) window because we want to split that again. - (select-window (split-window nil size)) - (find-file (car file-list)) - (setq file-list (cdr file-list))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-xemacs-highlight.el --- a/lisp/dired/dired-xemacs-highlight.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,207 +0,0 @@ -;;; Copyright (C) 1993 Cengiz Alaettinoglu -;;; Cengiz Alaettinoglu - -;;; Copyright (C) 1991 Tim Wilson and Sebastian Kremer -;;; Tim.Wilson@cl.cam.ac.uk -;;; Sebastian Kremer -;;; Modified to work with XEmacs - -;; Keywords: dired extensions, faces - -;; 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 -;; 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. - -;; 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. - -;;; Synched up with: Not synched with FSF. - - -; How to install -; (add-hook 'dired-load-hook '(lambda () (require 'dired-xemacs-highlight)) t) - -(require 'dired) -(require 'dired-extra "dired-x") -(provide 'dired-xemacs-highlight) - -(or (find-face 'dired-face-marked) - (and - (make-face 'dired-face-marked) - (or (face-differs-from-default-p 'dired-face-marked) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-marked (face-foreground 'default)) - (set-face-background 'dired-face-marked "PaleVioletRed")) - (set-face-underline-p 'dired-face-marked t))))) - -(or (find-face 'dired-face-deleted) - (and - (make-face 'dired-face-deleted) - (or (face-differs-from-default-p 'dired-face-deleted) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-deleted - (face-foreground 'default)) - (set-face-background 'dired-face-deleted "LightSlateGray")) - (set-face-underline-p 'dired-face-deleted t))))) - -(or (find-face 'dired-face-directory) - (and - (make-face 'dired-face-directory) - (or (face-differs-from-default-p 'dired-face-directory) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-directory - (face-foreground 'default)) - (make-face-bold 'dired-face-directory)) - (make-face-bold-italic 'dired-face-directory))))) - -(or (find-face 'dired-face-executable) - (and - (make-face 'dired-face-executable) - (or (face-differs-from-default-p 'dired-face-executable) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-executable "SeaGreen") - (make-face-bold 'dired-face-executable))))) - -(or (find-face 'dired-face-setuid) - (and - (make-face 'dired-face-setuid) - (or (face-differs-from-default-p 'dired-face-setuid) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-setuid "Red") - (make-face-bold 'dired-face-setuid))))) - -(or (find-face 'dired-face-socket) - (and - (make-face 'dired-face-socket) - (or (face-differs-from-default-p 'dired-face-socket) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-socket "Gold") - (make-face-italic 'dired-face-socket))))) - -(or (find-face 'dired-face-symlink) - (and - (make-face 'dired-face-symlink) - (or (face-differs-from-default-p 'dired-face-symlink) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-symlink "MediumBlue") - (make-face-bold 'dired-face-symlink)) - (make-face-italic 'dired-face-symlink))))) - -(or (find-face 'dired-face-boring) - (and - (make-face 'dired-face-boring) - (or (face-differs-from-default-p 'dired-face-boring) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-boring "Grey") - (set-face-background-pixmap - 'dired-face-boring - [32 2 "\125\125\125\125\252\252\252\252"]))))) - -(defvar dired-do-permission-highlighting-too nil - "Set if we think we should use dired-chmod style permission highlighting. -This is determined at first-pass time, to avoid filtering the buffer twice.") - -(defvar dired-x11-re-boring (if (fboundp 'dired-omit-regexp) - (dired-omit-regexp) - "^#\\|~$") - "Regexp to match backup, autosave and otherwise boring files. -Those files are displayed in a boring color such as grey (see -variable `dired-x11-boring-color').") - -(defvar dired-re-socket - (concat dired-re-maybe-mark dired-re-inode-size "s")) - -(defvar dired-re-setuid - (concat dired-re-maybe-mark dired-re-inode-size - "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") - "setuid plain file (even if not executable)") - -(defvar dired-re-setgid - (concat dired-re-maybe-mark dired-re-inode-size - "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]") - "setgid plain file (even if not executable)") - -(defun dired-xemacs-highlight-one (face) - (and (dired-move-to-filename t) - (set-extent-face (make-extent (dired-move-to-filename) - (dired-move-to-end-of-filename)) - face))) - -(defun dired-xemacs-highlight () - (message "Highlighting... directory") - ;; Let's try to do this in one pass... - (setq dired-do-permission-highlighting-too - (or dired-do-permission-highlighting-too (featurep 'dired-chmod))) - (if (and dired-do-permission-highlighting-too - (member 'dired-permissions-highlight dired-after-readin-hook)) - (remove-hook 'dired-after-readin-hook 'dired-permissions-highlight)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (eolp)) - (progn - (beginning-of-line) - (cond - ((re-search-forward - dired-x11-re-boring - (save-excursion - (end-of-line) - (point)) - t) - (dired-xemacs-highlight-one 'dired-face-boring)) - ((looking-at dired-re-dir) - (dired-xemacs-highlight-one 'dired-face-directory)) - ((looking-at dired-re-sym) - (dired-xemacs-highlight-one 'dired-face-symlink)) - ((or (looking-at dired-re-setuid) - (looking-at dired-re-setgid)) - (dired-xemacs-highlight-one 'dired-face-setuid)) - ((looking-at dired-re-exe) - (dired-xemacs-highlight-one 'dired-face-executable)) - ((looking-at dired-re-socket) - (dired-xemacs-highlight-one 'dired-face-socket))) - (if dired-do-permission-highlighting-too - (dired-make-permissions-interactive)))) - (forward-line 1)) - (message "Highlighting...done") - )) - -;FSF's version? -;(defconst dired-font-lock-keywords -; (list (cons "^\\*.*$" 'dired-face-marked) -; (cons "^\\D.*$" 'dired-face-deleted))) - -(defconst dired-font-lock-keywords (purecopy - (let ((bn (concat "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|" - "Aug\\|Sep\\|Oct\\|Nov\\|Dec\\) +[0-9]+ +[0-9:]+"))) - (list - '("^ [/~].*:$" . bold-italic) ; Header - (list (concat "^\\(\\([^ ].*\\)" bn "\\) \\(.*\\)$") 1 'bold) ; Marked - (list (concat "^. +d.*" bn " \\(.*\\)$") 2 'bold) ; Subdirs - (list (concat "^. +l.*" bn " \\(.*\\)$") 2 'italic) ; Links - (cons (concat "^. +-..[xsS]......\\|" ; Regular files with executable - "^. +-.....[xsS]...\\|" ; or setuid/setgid bits set - "^. +-........[xsS]") - 'bold) - ;; Possibly we should highlight more types of files differently: - ;; backups; autosaves; core files? Those with ignored-extensions? - ))) - "Expressions to highlight in Dired buffers.") - -(put 'dired-mode 'font-lock-keywords 'dired-font-lock-keywords) - -(add-hook 'dired-after-readin-hook 'dired-xemacs-highlight) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired-xemacs-menu.el --- a/lisp/dired/dired-xemacs-menu.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,247 +0,0 @@ -;;; dired-xemacs-menu.el: A menu for the dired-mode. -;;; v2.90; 7 Dec 1993 -;;; Copyright (C) 1993 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(require 'mode-motion) - -;; Popup and Pulldown Menu - -(defvar dired-menu - '("Dired Commands" - ["Open File" dired-find-file t] - ["Open File Other Window" dired-find-file-other-window t] - ["View File" dired-view-file t] - "----" - ("Mark" - ["Mark File" dired-mark-subdir-or-file t] - ["Mark Files in Region" dired-mark-region (mark)] - ["Mark Files by Regexp..." dired-mark-files-regexp t] - ["Mark All Directories" dired-mark-directories t] - ["Mark All Executables" dired-mark-executables t] - ["Mark All Symbolic Links" dired-mark-symlinks t] - "----" - ["Unmark File" dired-unmark-subdir-or-file t] - ["Unmark All Files" (dired-unflag-all-files nil) t] - ["Unmark All Files (Query)..." (dired-unflag-all-files nil t) t] - ["Unmark Files in Region" dired-unmark-region (mark)] - ) - ("Copy/Link" - ["Copy Files..." dired-do-copy t] - ["Copy Files by Regexp..." dired-do-copy-regexp t] - "----" - ["Symlink Files in Directory..." dired-do-symlink t] - ["Symlink Files in Directory by Regexp..." dired-do-symlink-regexp t] - "----" - ["Hard-Link Files in Directory..." dired-do-hardlink t] - ["Hard-Link Files in Directory by Regexp..." dired-do-hardlink-regexp t] - ) - ("Rename" - ["Rename Marked Files..." dired-do-move t] - ["Rename Files by Regexp..." dired-do-rename-regexp t] - "----" - ["Downcase Names of Marked Files..." dired-downcase t] - ["Upcase Names of Marked Files..." dired-upcase t] - ) - ("Delete" - ["Delete Marked Files..." dired-do-delete t] - ["Delete Flagged Files..." dired-do-deletions t] - "----" - ["Flag Marked Files for Deletion" dired-flag-file-deleted t] - ["Flag Files in Region for Deletion" dired-flag-region (mark)] - ["Flag Files for Deletion by Regexp..." dired-flag-regexp-files t] - ["Flag Backup Files for Deletion" dired-clean-directory t] - ["Flag Autosave Files for Deletion" dired-flag-auto-save-files t] - "----" - ["Unflag Marked Files" dired-unflag t] - ["Unflag Backup Files" dired-backup-unflag t] - ["Unflag All Files" (dired-unflag-all-files nil) t] - ["Unflag All Files (Query)..." (dired-unflag-all-files nil) t] - ["Unflag Files in Region" dired-unflag-region (mark)] - ) - ("Shell commands" - ["Compress Marked Files..." dired-do-compress t] - ["Uncompress Marked Files..." dired-do-uncompress t] - ["Print Marked Files..." dired-do-print t] - ["Shell Command on Marked Files..." dired-do-shell-command t] - "----" - ["Load Marked Files" dired-do-load t] - ["Byte-Compile Marked Files..." dired-do-byte-compile t] - "----" - ["Diff File Against Backup" dired-backup-diff t] - ["Diff File..." dired-diff t] - "----" - ["Change Permissions of Marked Files..." dired-do-chmod t] - ["Change Group of Marked Files..." dired-do-chgrp t] - ["Change Owner of Marked Files..." dired-do-chown t] - ) - "----" - ("Directory" - ["Up Directory" dired-up-directory t] - ["Home Directory" (dired "~/") t] - "----" - ["Dired..." dired t] - ["Dired Other Window..." dired-other-window t] - ["Redisplay All Files" revert-buffer t] - "----" - ["Create Directory..." dired-create-directory t] - "----" - ["Insert Subdirectory" dired-insert-subdir t] - ["Hide Subdirectory" dired-kill-subdir t] - ["Hide All Subdirectories..." dired-kill-tree t] - ) - ("Goto" - ["Next Directory Line" dired-next-dirline t] - ["Previous Directory Line" dired-prev-dirline t] - ["Next Marked File" dired-next-marked-file t] - ["Previous Marked File" dired-prev-marked-file t] - "----" - ["File..." dired-goto-file t] - ["Top of Directory..." dired-goto-subdir t] - ["Down Directory" dired-tree-down t] - ["Up Directory" dired-tree-up t] - ) - ("Display" - ["Undisplay Line or Subdirectory" dired-kill-line-or-subdir t] - ["Undisplay Tree" dired-kill-tree t] - ["Undisplay Marked Lines" dired-do-kill t] - "----" - ["Redisplay All Files" revert-buffer t] - ["Redisplay All Marked Files" dired-do-redisplay t] - ["Undo" dired-undo t] - "----" - ["Sort by Date/Name (Toggle)" dired-sort-toggle-or-edit t] - ["Edit `ls' Switches..." (dired-sort-toggle-or-edit t) t] - ) - "----" - ("Options, This Buffer" - ["Action is find-file" (set (make-local-variable 'dired-mouse-action) - 'dired-mouse-find-file) - :style radio - :selected (eq dired-mouse-action 'dired-mouse-find-file)] - ["Action is find-file-other-window" - (set (make-local-variable 'dired-mouse-action) - 'dired-mouse-find-file-other-window) - :style radio - :selected (eq dired-mouse-action 'dired-mouse-find-file-other-window)]) - ("Options, Global" - ["Action is find-file" (setq-default dired-mouse-action - 'dired-mouse-find-file) - :style radio - :selected (eq (default-value 'dired-mouse-action) - 'dired-mouse-find-file)] - ["Action is find-file-other-window" - (setq-default dired-mouse-action 'dired-mouse-find-file-other-window) - :style radio - :selected (eq (default-value 'dired-mouse-action) - 'dired-mouse-find-file-other-window)]) - "----" - ["Explain Last Failure" dired-why t] - ) - "*The menu for Dired.") - -(defun dired-mouse-file-on-line-p (event) - "Return t if there is a file under the mouse." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (if (dired-move-to-filename) - t - nil))) - -(defun dired-mode-motion-highlight-line (event) - (if (dired-mouse-file-on-line-p event) - (mode-motion-highlight-line event))) - -(defun dired-install-menubar () - "Installs the Dired menu at the menubar." - (if (and (boundp 'current-menubar) current-menubar - (not (assoc "Dired" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Dired" (cdr dired-menu)))) - (make-local-variable 'mode-motion-hook) - (setq mode-motion-hook '(dired-mode-motion-highlight-line - mode-motion-add-help-echo)) - ;; #### double-click left is supposed to work but it doesn't. - ;; I'm not sure why. - (setq mode-motion-help-echo-string - "Middle button to select file under mouse.") - ) -(add-hook 'dired-mode-hook 'dired-install-menubar) - -(defun dired-popup-menu (event) - "Display the Dired Menu." - (interactive "@e") - (mouse-set-point event) - (dired-next-line 0) - (popup-menu dired-menu)) - -(defun dired-mouse-find-file (event) - "Edit the file under the mouse." - (interactive "e") - (mouse-set-point event) - (dired-next-line 0) - (dired-find-file)) - -(defun dired-mouse-find-file-other-window (event) - "Edit the file under the mouse, in another window." - (interactive "e") - (mouse-set-point event) - (dired-next-line 0) - (dired-find-file-other-window)) - -(defvar dired-mouse-action 'dired-mouse-find-file - "*Function to be called when button2 is clicked on a file in Dired.") - -(defun dired-mouse-do-action (event) - (interactive "e") - (funcall dired-mouse-action event)) - -(defun dired-mark-region (&optional form-to-eval) - "Mark all files in the region." - (interactive) - (or form-to-eval (setq form-to-eval '(dired-mark-subdir-or-file nil))) - (save-excursion - (let ((end (region-end))) - (goto-char (region-beginning)) - (beginning-of-line) - (while (<= (point) end) - (save-excursion (eval form-to-eval)) - (forward-line 1))))) - -(defun dired-unmark-region () - "Unmark all files in the region." - (interactive) - (dired-mark-region '(dired-unmark-subdir-or-file nil))) - -(defun dired-flag-region () - "Flag all files in the region for deletion." - (interactive) - (dired-mark-region '(dired-flag-file-deleted nil))) - -(defun dired-unflag-region () - "Unflag all files in the region for deletion." - (interactive) - (dired-mark-region '(dired-unflag 1))) - - -(define-key dired-mode-map 'button2 'dired-mouse-do-action) -(define-key dired-mode-map 'button3 'dired-popup-menu) - - -(provide 'dired-xemacs-menu) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/dired.el --- a/lisp/dired/dired.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3788 +0,0 @@ -;;; dired.el --- directory-browsing commands -;; Keywords: dired extensions - -;; Copyright (C) 1985, 1986, 1991, 1992 Free Software Foundation, Inc. - -;; 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 -;; 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. - -;; 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. - -;; Rewritten in 1990/1991 to add tree features, file marking and -;; sorting by Sebastian Kremer . - -(provide 'dired) - -(defconst dired-version (substring "!Revision: 6.0 !" 11 -2) - "The revision number of Tree Dired (as string). The complete RCS id is: - - !Id: dired.el,v 6.0 1992/05/15 14:25:45 sk RelBeta ! - -Don't forget to mention this when reporting bugs to: - - Sebastian Kremer - -Tree dired is available for anonymous ftp in USA in: - - ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z - -and in Europe at my own site in Germany: - - ftp.uni-koeln.de:/pub/gnu/emacs/diredall.tar.Z") -;; Should perhaps later give bug-gnu-emacs@prep.gnu.ai.mit.edu instead. - -;; compatibility package when using Emacs 18.55 -;; XEmacs fix: -(defvar dired-emacs-19-p (not (equal (substring emacs-version 0 2) "18"))) -;;;#### install (is there a better way to test for Emacs 19?) -(or dired-emacs-19-p - (require 'emacs-19)) - -;;; Customizable variables - -;;; The funny comments are for autoload.el, to automagically update -;;; loaddefs. - -(defvar dired-use-gzip-instead-of-compress t - "*If non-nil, use gzip instead of compress as the standard compress -program") - -(defvar dired-make-gzip-quiet t - "*If non-nil, pass -q to shell commands involving gzip this will override -GZIP environment variable.") - -(defvar dired-znew-switches nil - "*If non-nil, a string of switches that will be passed to `znew' -example: \"-K\"") - -(defvar dired-gzip-file-extension ".gz" - "*A string representing the suffix created by gzip. This should probably -match the value of --suffix or -S in the GZIP environment variable if it -exists and \".gz\" if it does not.") - -;;;###autoload -(defvar dired-listing-switches (purecopy "-al") - "*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -; Don't use absolute paths as /bin should be in any PATH and people -; may prefer /usr/local/gnu/bin or whatever. However, chown is -; usually not in PATH. - -;;;###autoload -(defvar dired-chown-program - (purecopy - (if (memq system-type '(dgux-unix hpux usg-unix-v silicon-graphics-unix irix)) - "chown" "/etc/chown")) - "*Name of chown command (usully `chown' or `/etc/chown').") - -;;;###autoload -(defvar dired-ls-program (purecopy "ls") - "*Absolute or relative name of the ls program used by dired.") - -;;;###autoload -(defvar dired-ls-F-marks-symlinks t - "*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). - -Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to -nil, if it gives `bar@ -> foo', set it to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t.") - -;;;###autoload -(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") - "*Regexp of files to skip when moving point to the first file of a new directory listing. -Nil means move to the subdir line, t means move to first file.") - -;;;###autoload -(defvar dired-keep-marker-move t - ;; Use t as default so that moved files `take their markers with them' - "If t, moved marked files are marked if their originals were. -If a character, those files (marked or not) are marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-copy ?C - "If t, copied files are marked if their source files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-hardlink ?H - "If t, hard-linked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-symlink ?Y - "If t, symlinked marked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-dwim-target nil - "*If non-nil, dired tries to guess a default target directory: -If there is a dired buffer displayed in the next window, use -its current subdir, instead of the current subdir of this dired -buffer. - -The target is used in the prompt for file copy, move etc.") - -;;;###autoload -(defvar dired-copy-preserve-time nil - "*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -;;; Hook variables - -(defvar dired-load-hook nil - "Run after loading dired. -You can customize key bindings or load extensions with this.") - -(defvar dired-mode-hook nil - "Run at the very end of dired-mode.") - -(defvar dired-before-readin-hook nil - "This hook is run before a dired buffer is newly read in (created or reverted).") - -(defvar dired-after-readin-hook nil - "After each listing of a file or directory, this hook is run -with the buffer narrowed to the listing.") -;; Note this can't simply be run inside function dired-ls as the hook -;; functions probably depend on the dired-subdir-alist to be OK. - -;;; Internal variables - -(defvar dired-marker-char ?* ; the answer is 42 - ;; so that you can write things like - ;; (let ((dired-marker-char ?X)) - ;; ;; great code using X markers ... - ;; ) - ;; For example, commands operating on two sets of files, A and B. - ;; Or marking files with digits 0-9. This could implicate - ;; concentric sets or an order for the marked files. - ;; The code depends on dynamic scoping on the marker char. - "In dired, character used to mark files for later commands.") - -(defvar dired-del-marker ?D - "Character used to flag files for deletion.") - -(defvar dired-shrink-to-fit - (if (fboundp 'baud-rate) (> (baud-rate) search-slow-speed) t) - "Whether dired shrinks the display buffer to fit the marked files.") - -(defvar dired-flagging-regexp nil);; Last regexp used to flag files. - -(defvar dired-directory nil - "The directory name or shell wildcard passed as argument to ls. -Local to each dired buffer.") - -(defvar dired-actual-switches nil - "The actual (buffer-local) value of `dired-listing-switches'.") - -(defvar dired-re-inode-size "[0-9 \t]*" - "Regexp for optional initial inode and file size as produced by ls' -i and -s flags.") - -;; These regexps must be tested at beginning-of-line, but are also -;; used to search for next matches, so neither omitting "^" nor -;; replacing "^" by "\n" (to make it slightly faster) will work. - -(defvar dired-re-mark "^[^ \n]") -;; "Regexp matching a marked line. -;; Important: the match ends just after the marker." -(defvar dired-re-maybe-mark "^. ") -;; Note that dired-re-inode-size allows for an arbitray amount of -;; whitespace, making nested indentation in dired-nstd.el work. -(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) -(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) -(defvar dired-re-exe;; match ls permission string of an executable file - (mapconcat (function - (lambda (x) - (concat dired-re-maybe-mark dired-re-inode-size x))) - '("-[-r][-w][xs][-r][-w].[-r][-w]." - "-[-r][-w].[-r][-w][xs][-r][-w]." - "-[-r][-w].[-r][-w].[-r][-w][xst]") - "\\|")) -(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' - -(defvar dired-subdir-alist nil - "Association list of subdirectories and their buffer positions: - - \((LASTDIR . LASTMARKER) ... (DEFAULT-DIRECTORY . FIRSTMARKER)).") - -(defvar dired-subdir-regexp "^. \\([^ \n\r]+\\)\\(:\\)[\n\r]" - "Regexp matching a maybe hidden subdirectory line in ls -lR output. -Subexpression 1 is the subdirectory proper, no trailing colon. -The match starts at the beginning of the line and ends after the end -of the line (\\n or \\r). -Subexpression 2 must end right before the \\n or \\r.") - - -;;; Macros must be defined before they are used - for the byte compiler. - -;; Returns the count if any work was done, nil otherwise. -(defmacro dired-mark-if (predicate msg) - (` (let (buffer-read-only count) - (save-excursion - (setq count 0) - (if (, msg) (message "Marking %ss..." (, msg))) - (goto-char (point-min)) - (while (not (eobp)) - (if (, predicate) - (progn - (delete-char 1) - (insert dired-marker-char) - (setq count (1+ count)))) - (forward-line 1)) - (if (, msg) (message "%s %s%s %s%s." - count - (, msg) - (dired-plural-s count) - (if (eq dired-marker-char ?\040) "un" "") - (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) - (and (> count 0) count)))) - -(defmacro dired-mark-map (body arg &optional show-progress) -;; "Macro: Perform BODY with point somewhere on each marked line -;;and return a list of BODY's results. -;;If no marked file could be found, execute BODY on the current line. -;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) -;; files instead of the marked files. -;; In that case point is dragged along. This is so that commands on -;; the next ARG (instead of the marked) files can be chained easily. -;; If ARG is otherwise non-nil, use current file instead. -;;If optional third arg SHOW-PROGRESS evaluates to non-nil, -;; redisplay the dired buffer after each file is processed. -;;No guarantee is made about the position on the marked line. -;; BODY must ensure this itself if it depends on this. -;;Search starts at the beginning of the buffer, thus the car of the list -;; corresponds to the line nearest to the buffer's bottom. This -;; is also true for (positive and negative) integer values of ARG. -;;BODY should not be too long as it is expanded four times." -;; -;;Warning: BODY must not add new lines before point - this may cause an -;;endless loop. -;;This warning should not apply any longer, sk 2-Sep-1991 14:10. - (` (prog1 - (let (buffer-read-only case-fold-search found results) - (if (, arg) - (if (integerp (, arg)) - (progn;; no save-excursion, want to move point. - (dired-repeat-over-lines - (, arg) - (function (lambda () - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results))))) - (if (< (, arg) 0) - (nreverse results) - results)) - ;; non-nil, non-integer ARG means use current file: - (list (, body))) - (let ((regexp (dired-marker-regexp)) next-position) - (save-excursion - (goto-char (point-min)) - ;; remember position of next marked file before BODY - ;; can insert lines before the just found file, - ;; confusing us by finding the same marked file again - ;; and again and... - (setq next-position (and (re-search-forward regexp nil t) - (point-marker)) - found (not (null next-position))) - (while next-position - (goto-char next-position) - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results)) - ;; move after last match - (goto-char next-position) - (forward-line 1) - (set-marker next-position nil) - (setq next-position (and (re-search-forward regexp nil t) - (point-marker))))) - (if found - results - (list (, body)))))) - ;; save-excursion loses, again - (dired-move-to-filename)))) - -(defun dired-mark-get-files (&optional localp arg) - "Return the marked files as list of strings. -The list is in the same order as the buffer, that is, the car is the - first marked file. -Values returned are normally absolute pathnames. -Optional arg LOCALP as in `dired-get-filename'. -Optional second argument ARG forces to use other files. If ARG is an - integer, use the next ARG files. If ARG is otherwise non-nil, use - current file. Usually ARG comes from the current prefix arg." - (nreverse (save-excursion (dired-mark-map (dired-get-filename localp) arg)))) - - -;; Function dired-ls is redefinable for VMS, ange-ftp, Prospero or -;; other special applications. - -;; dired-ls -;; - must insert _exactly_one_line_ describing FILE if WILDCARD and -;; FULL-DIRECTORY-P is nil. -;; The single line of output must display FILE's name as it was -;; given, namely, an absolute path name. -;; - must insert exactly one line for each file if WILDCARD or -;; FULL-DIRECTORY-P is t, plus one optional "total" line -;; before the file lines, plus optional text after the file lines. -;; Lines are delimited by "\n", so filenames containing "\n" are not -;; allowed. -;; File lines should display the basename, not a path name. -;; - must drag point after inserted text -;; - must be consistent with -;; - functions dired-move-to-filename, (these two define what a file line is) -;; dired-move-to-end-of-filename, -;; dired-between-files, (shortcut for (not (dired-move-to-filename))) -;; dired-insert-headerline -;; dired-after-subdir-garbage (defines what a "total" line is) -;; - variables dired-subdir-regexp -(defun dired-ls (file switches &optional wildcard full-directory-p) -; "Insert ls output of FILE, formatted according to SWITCHES. -;Optional third arg WILDCARD means treat FILE as shell wildcard. -;Optional fourth arg FULL-DIRECTORY-P means file is a directory and -;switches do not contain `d', so that a full listing is expected. -; -;Uses dired-ls-program (and shell-file-name if WILDCARD) to do the work." - (if wildcard - (let ((default-directory (file-name-directory file))) - (call-process shell-file-name nil t nil - "-c" (concat dired-ls-program " -d " switches " " - (file-name-nondirectory file)))) - (call-process dired-ls-program nil t nil switches file))) - -;; The dired command - -(defun dired-read-dir-and-switches (str) - ;; For use in interactive. - (reverse (list - (if current-prefix-arg - (read-string "Dired listing switches: " - dired-listing-switches)) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil)))) - -;;;###autoload (define-key ctl-x-map "d" 'dired) -;;;###autoload -(defun dired (dirname &optional switches) - "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -With an optional prefix argument you can specify the ls SWITCHES that are used. -Dired displays a list of files in DIRNAME (which may also have - shell wildcards appended to select certain files). -You can move around in it with the usual commands. -You can flag files for deletion with \\\\[dired-flag-file-deleted] and then delete them by - typing \\[dired-do-deletions]. -Type \\[describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." - ;; Cannot use (interactive "D") because of wildcards. - (interactive (dired-read-dir-and-switches "")) - (switch-to-buffer (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) -;;;###autoload -(defun dired-other-window (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." - (interactive (dired-read-dir-and-switches "in other window ")) - (switch-to-buffer-other-window (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) -;;;###autoload -(defun dired-other-frame (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." - (interactive (dired-read-dir-and-switches "in other frame ")) - (switch-to-buffer-other-frame (dired-noselect dirname switches))) - -;;;###autoload -(defun dired-noselect (dirname &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - ;; This loses the distinction between "/foo/*/" and "/foo/*" that - ;; some shells make: - (setq dirname (expand-file-name (directory-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (dired-internal-noselect dirname switches)) - -;; Separate function from dired-noselect for the sake of dired-vms.el. -(defun dired-internal-noselect (dirname &optional switches) - ;; If there is an existing dired buffer for DIRNAME, just leave - ;; buffer as it is (don't even call dired-revert). - ;; This saves time especially for deep trees or with ange-ftp. - ;; The user can type `g'easily, and it is more consistent with find-file. - ;; But if SWITCHES are given they are probably different from the - ;; buffer's old value, so call dired-sort-other, which does - ;; revert the buffer. - ;; A pity we can't possibly do "Directory has changed - refresh? " - ;; like find-file does...maybe in the GNU OS. - (let* ((buffer (dired-find-buffer-nocreate dirname)) - ;; note that buffer already is in dired-mode, if found - (new-buffer-p (not buffer)) - (old-buf (current-buffer))) - (or buffer - (let ((default-major-mode 'fundamental-mode)) - ;; We don't want default-major-mode to run hooks and set auto-fill - ;; or whatever, now that dired-mode does not - ;; kill-all-local-variables any longer. - (setq buffer (create-file-buffer (directory-file-name dirname))))) - (set-buffer buffer) - (if (not new-buffer-p) ; existing buffer ... - (if switches ; ... but new switches - (dired-sort-other switches)) ; this calls dired-revert - ;; Else a new buffer - (setq default-directory (if (file-directory-p dirname) - dirname - (file-name-directory dirname))) - (or switches (setq switches dired-listing-switches)) - (dired-mode dirname switches) - ;; default-directory and dired-actual-switches are set now - ;; (buffer-local), so we can call dired-readin: - (let ((failed t)) - (unwind-protect - (progn (dired-readin dirname buffer) - (setq failed nil)) - ;; dired-readin can fail if parent directories are inaccessible. - ;; Don't leave an empty buffer around in that case. - (if failed (kill-buffer buffer)))) - ;; No need to narrow since the whole buffer contains just - ;; dired-readin's output, nothing else. The hook can - ;; successfully use dired functions (e.g. dired-get-filename) - ;; as the subdir-alist has been built in dired-readin. - (let ((buffer-read-only nil)) - (run-hooks 'dired-after-readin-hook)) - (goto-char (point-min)) - (dired-initial-position dirname)) - (set-buffer old-buf) - buffer)) - -;; This differs from dired-buffers-for-dir in that it does not consider -;; subdirs of default-directory and searches for the first match only -(defun dired-find-buffer-nocreate (dirname) - (let (found (blist (buffer-list))) - (while blist - (save-excursion - (set-buffer (car blist)) - (if (and (eq major-mode 'dired-mode) - (equal dired-directory dirname)) - (setq found (car blist) - blist nil) - (setq blist (cdr blist))))) - found)) - - -;; Read in a new dired buffer - -;; dired-readin differs from dired-insert-subdir in that it accepts -;; wildcards, erases the buffer, and builds the subdir-alist anew -;; (including making it buffer-local and clearing it first). -(defun dired-readin (dirname buffer) - ;; default-directory and dired-actual-switches must be buffer-local - ;; and initialized by now. - ;; Thus we can test (equal default-directory dirname) instead of - ;; (file-directory-p dirname) and save a filesystem transaction. - ;; Also, we can run this hook which may want to modify the switches - ;; based on default-directory, e.g. with ange-ftp to a SysV host - ;; where ls won't understand -Al switches. - (setq dirname (expand-file-name dirname)) - (run-hooks 'dired-before-readin-hook) - (save-excursion - (message "Reading directory %s..." dirname) - (set-buffer buffer) - (let (buffer-read-only) - (widen) - (erase-buffer) - (dired-readin-insert dirname) - (dired-indent-rigidly (point-min) (point-max) 2) - ;; We need this to make the root dir have a header line as all - ;; other subdirs have: - (goto-char (point-min)) - (dired-insert-headerline default-directory) - ;; can't run dired-after-readin-hook here, it may depend on the subdir - ;; alist to be OK. - ) - (message "Reading directory %s...done" dirname) - (set-buffer-modified-p nil) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (set (make-local-variable 'dired-subdir-alist) nil) - (let (case-fold-search) - (if (string-match "R" dired-actual-switches) - (dired-build-subdir-alist) - ;; no need to parse the buffer if listing is not recursive - (dired-simple-subdir-alist))))) - -;; Subroutines of dired-readin - -(defun dired-readin-insert (dirname) - ;; Just insert listing for DIRNAME, assuming a clean buffer. - (let ((font-lock-mode nil)) - (if (equal default-directory dirname);; i.e., (file-directory-p dirname) - (dired-ls (if (or (let (case-fold-search) - (string-match "R" dired-actual-switches)) - (eq system-type 'vax-vms)) - dirname - ;; On SysV derived system, symbolic links to - ;; directories are not resolved, while on BSD - ;; derived it suffices to let DIRNAME end in slash. - ;; We always let it end in "/." since it does no - ;; harm on BSD and makes Dired work on such links on - ;; SysV. - ;; Cannot do this with -R since "dir/./subdir" - ;; headerlines would result, utterly confusing dired. - (concat dirname ".")) - dired-actual-switches nil t) - (if (not (file-readable-p - (directory-file-name (file-name-directory dirname)))) - (error "Directory %s inaccessible or nonexistent" dirname) - ;; else assume it contains wildcards: - (dired-ls dirname dired-actual-switches t) - (save-excursion;; insert wildcard instead of total line: - (goto-char (point-min)) - (insert "wildcard " (file-name-nondirectory dirname) "\n")))))) - -(defun dired-insert-headerline (dir);; also used by dired-insert-subdir - ;; Insert DIR's headerline with no trailing slash, exactly like ls - ;; would, and put cursor where dired-build-subdir-alist puts subdir - ;; boundaries. - (save-excursion (insert " " (directory-file-name dir) ":\n"))) - -;; Make the file names highlight when the mouse is on them. -;; from FSF 19.30. -(defun dired-insert-set-properties (beg end) - (save-excursion - (goto-char beg) - (while (< (point) end) - (condition-case nil - (if (dired-move-to-filename) - (put-text-property (point) - (save-excursion - (dired-move-to-end-of-filename) - (point)) - 'highlight t)) - (error nil)) - (forward-line 1)))) - - -;; Reverting a dired buffer - -(defun dired-revert (&optional arg noconfirm) - ;; Reread the dired buffer. Must also be called after - ;; dired-actual-switches have changed. - ;; Should not fail even on completely garbaged buffers. - ;; Preserves old cursor, marks/flags, hidden-p. - (widen) ; just in case user narrowed - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (mark-alist nil) ; save marked files - (hidden-subdirs (dired-remember-hidden)) - (old-subdir-alist (cdr (reverse dired-subdir-alist))) ; except pwd - case-fold-search ; we check for upper case ls flags - buffer-read-only) - (goto-char (point-min)) - (setq mark-alist;; only after dired-remember-hidden since this unhides: - (dired-remember-marks (point-min) (point-max))) - ;; treat top level dir extra (it may contain wildcards) - (dired-readin dired-directory (current-buffer)) - (let ((dired-after-readin-hook nil)) - ;; don't run that hook for each subdir... - (dired-insert-old-subdirs old-subdir-alist)) - (dired-mark-remembered mark-alist) ; mark files that were marked - ;; ... run the hook for the whole buffer, and only after markers - ;; have been reinserted (else omitting in dired-x would omit marked files) - (run-hooks 'dired-after-readin-hook) ; no need to narrow - (or (and ofile (dired-goto-file ofile)) ; move cursor to where it - (goto-char opoint)) ; was before - (dired-move-to-filename) - (save-excursion ; hide subdirs that were hidden - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs))) - ;; outside of the let scope - (setq buffer-read-only t)) - -;; Subroutines of dired-revert -;; Some of these are also used when inserting subdirs. - -(defun dired-remember-marks (beg end) - ;; Return alist of files and their marks, from BEG to END. - (if selective-display ; must unhide to make this work. - (let (buffer-read-only) - (subst-char-in-region beg end ?\r ?\n))) - (let (fil chr alist) - (save-excursion - (goto-char beg) - (while (re-search-forward dired-re-mark end t) - (if (setq fil (dired-get-filename nil t)) - (setq chr (preceding-char) - alist (cons (cons fil chr) alist))))) - alist)) - -(defun dired-mark-remembered (alist) - ;; Mark all files remembered in ALIST. - (let (elt fil chr) - (while alist - (setq elt (car alist) - alist (cdr alist) - fil (car elt) - chr (cdr elt)) - (if (dired-goto-file fil) - (save-excursion - (beginning-of-line) - (delete-char 1) - (insert chr)))))) - -(defun dired-remember-hidden () - (let ((l dired-subdir-alist) dir result) - (while l - (setq dir (car (car l)) - l (cdr l)) - (if (dired-subdir-hidden-p dir) - (setq result (cons dir result)))) - result)) - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (or (string-match "R" dired-actual-switches) - (let (elt dir) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt)) - (condition-case () - (dired-insert-subdir dir) - (error nil)))))) - - -;; dired mode key bindings and initialization - -(defvar dired-mode-map nil "Local keymap for dired-mode buffers.") -(if dired-mode-map - nil - ;; Force `f' rather than `e' in the mode doc: - (fset 'dired-advertised-find-file 'dired-find-file) - ;; This looks ugly when substitute-command-keys uses C-d instead d: - ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted) - - (setq dired-mode-map (make-keymap)) - (suppress-keymap dired-mode-map) - ;; Commands to mark certain categories of files - (define-key dired-mode-map "#" 'dired-flag-auto-save-files) - (define-key dired-mode-map "*" 'dired-mark-executables) - (define-key dired-mode-map "." 'dired-clean-directory) - (define-key dired-mode-map "/" 'dired-mark-directories) - (define-key dired-mode-map "@" 'dired-mark-symlinks) - ;; Upper case keys (except !, c, r) for operating on the marked files - (define-key dired-mode-map "c" 'dired-do-copy) - (define-key dired-mode-map "r" 'dired-do-move) - (define-key dired-mode-map "!" 'dired-do-shell-command) - (define-key dired-mode-map "B" 'dired-do-byte-compile) - (define-key dired-mode-map "C" 'dired-do-compress) - (define-key dired-mode-map "G" 'dired-do-chgrp) - (define-key dired-mode-map "H" 'dired-do-hardlink) - (define-key dired-mode-map "L" 'dired-do-load) - (define-key dired-mode-map "M" 'dired-do-chmod) - (define-key dired-mode-map "O" 'dired-do-chown) - (define-key dired-mode-map "P" 'dired-do-print) - (define-key dired-mode-map "U" 'dired-do-uncompress) - (define-key dired-mode-map "X" 'dired-do-delete) - (define-key dired-mode-map "Y" 'dired-do-symlink) - ;; exceptions to the upper key rule - (define-key dired-mode-map "D" 'dired-diff) - (define-key dired-mode-map "W" 'dired-why) - ;; Tree Dired commands - (define-key dired-mode-map "\M-\C-?" 'dired-unflag-all-files) - (define-key dired-mode-map "\M-\C-d" 'dired-tree-down) - (define-key dired-mode-map "\M-\C-u" 'dired-tree-up) - (define-key dired-mode-map "\M-\C-n" 'dired-next-subdir) - (define-key dired-mode-map "\M-\C-p" 'dired-prev-subdir) - ;; move to marked files - (define-key dired-mode-map "\M-{" 'dired-prev-marked-file) - (define-key dired-mode-map "\M-}" 'dired-next-marked-file) - ;; kill marked files - (define-key dired-mode-map "\M-k" 'dired-do-kill) - ;; Make all regexp commands share a `%' prefix: - (fset 'dired-regexp-prefix (make-sparse-keymap)) - (define-key dired-mode-map "%" 'dired-regexp-prefix) - (define-key dired-mode-map "%u" 'dired-upcase) - (define-key dired-mode-map "%l" 'dired-downcase) - (define-key dired-mode-map "%d" 'dired-flag-regexp-files) - (define-key dired-mode-map "%m" 'dired-mark-files-regexp) - (define-key dired-mode-map "%r" 'dired-do-rename-regexp) - (define-key dired-mode-map "%c" 'dired-do-copy-regexp) - (define-key dired-mode-map "%H" 'dired-do-hardlink-regexp) - (define-key dired-mode-map "%Y" 'dired-do-symlink-regexp) - ;; Lower keys for commands not operating on all the marked files - (define-key dired-mode-map "d" 'dired-flag-file-deleted) - (define-key dired-mode-map "e" 'dired-find-file) - (define-key dired-mode-map "f" 'dired-advertised-find-file) - (define-key dired-mode-map "g" 'revert-buffer) - (define-key dired-mode-map "h" 'describe-mode) - (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) - (define-key dired-mode-map "k" 'dired-kill-line-or-subdir) - (define-key dired-mode-map "l" 'dired-do-redisplay) - (define-key dired-mode-map "m" 'dired-mark-subdir-or-file) - (define-key dired-mode-map "n" 'dired-next-line) - (define-key dired-mode-map "o" 'dired-find-file-other-window) - (define-key dired-mode-map "p" 'dired-previous-line) - (define-key dired-mode-map "q" 'dired-quit) - (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) - (define-key dired-mode-map "u" 'dired-unmark-subdir-or-file) - (define-key dired-mode-map "v" 'dired-view-file) - (define-key dired-mode-map "x" 'dired-do-deletions) - (define-key dired-mode-map "~" 'dired-flag-backup-files) - (define-key dired-mode-map "\M-~" 'dired-backup-diff) - (define-key dired-mode-map "+" 'dired-create-directory) - ;; moving - (define-key dired-mode-map "<" 'dired-prev-dirline) - (define-key dired-mode-map ">" 'dired-next-dirline) - (define-key dired-mode-map "^" 'dired-up-directory) - (define-key dired-mode-map " " 'dired-next-line) - (define-key dired-mode-map "\C-n" 'dired-next-line) - (define-key dired-mode-map "\C-p" 'dired-previous-line) - ;; hiding - (define-key dired-mode-map "$" 'dired-hide-subdir) - (define-key dired-mode-map "=" 'dired-hide-all) - ;; misc - (define-key dired-mode-map "?" 'dired-summary) - (define-key dired-mode-map "\177" 'dired-backup-unflag) - (define-key dired-mode-map "\C-_" 'dired-undo) - (define-key dired-mode-map "\C-xu" 'dired-undo) - ) - -(or (equal (assq 'dired-sort-mode minor-mode-alist) - '(dired-sort-mode dired-sort-mode)) - ;; Test whether this has already been done in case dired is reloaded - ;; There may be several elements with dired-sort-mode as car. - (setq minor-mode-alist - (cons '(dired-sort-mode dired-sort-mode) - ;; dired-sort-mode is nil outside dired - minor-mode-alist))) - -;; Dired mode is suitable only for specially formatted data. -(put 'dired-mode 'mode-class 'special) - -(defun dired-mode (&optional dirname switches) - "\ -Mode for \"editing\" directory listings. -In dired, you are \"editing\" a list of the files in a directory and - \(optionally) its subdirectories, in the format of `ls -lR'. - Each directory is a page: use \\[backward-page] and \\[forward-page] to move pagewise. -\"Editing\" means that you can run shell commands on files, visit, - compress, load or byte-compile them, change their file attributes - and insert subdirectories into the same buffer. You can \"mark\" - files for later commands or \"flag\" them for deletion, either file - by file or all files matching certain criteria. -You can move using the usual cursor motion commands.\\ -Letters no longer insert themselves. Digits are prefix arguments. -Instead, type \\[dired-flag-file-deleted] to flag a file for Deletion. -Type \\[dired-mark-subdir-or-file] to Mark a file or subdirectory for later commands. - Most commands operate on the marked files and use the current file - if no files are marked. Use a numeric prefix argument to operate on - the next ARG (or previous -ARG if ARG<0) files, or just `1' - to operate on the current file only. Prefix arguments override marks. - Mark-using commands display a list of failures afterwards. Type \\[dired-why] to see - why something went wrong. -Type \\[dired-unmark-subdir-or-file] to Unmark a file or all files of a subdirectory. -Type \\[dired-backup-unflag] to back up one line and unflag. -Type \\[dired-do-deletions] to eXecute the deletions requested. -Type \\[dired-advertised-find-file] to Find the current line's file - (or dired it in another buffer, if it is a directory). -Type \\[dired-find-file-other-window] to find file or dired directory in Other window. -Type \\[dired-maybe-insert-subdir] to Insert a subdirectory in this buffer. -Type \\[dired-do-move] to Rename a file or move the marked files to another directory. -Type \\[dired-do-copy] to Copy files. -Type \\[dired-sort-toggle-or-edit] to toggle sorting by name/date or change the ls switches. -Type \\[revert-buffer] to read all currently expanded directories again. - This retains all marks and hides subdirs again that were hidden before. -SPC and DEL can be used to move down and up by lines. - -If dired ever gets confused, you can either type \\[revert-buffer] \ -to read the -directories again, type \\[dired-do-redisplay] \ -to relist a single or the marked files or a -subdirectory, or type \\[dired-build-subdir-alist] to parse the buffer -again for the directory tree. - -Customization variables (rename this buffer and type \\[describe-variable] on each line -for more info): - - dired-listing-switches - dired-trivial-filenames - dired-shrink-to-fit - dired-marker-char - dired-del-marker - dired-keep-marker-move - dired-keep-marker-copy - dired-keep-marker-hardlink - dired-keep-marker-symlink - -Hooks (use \\[describe-variable] to see their documentation): - - dired-before-readin-hook - dired-after-readin-hook - dired-mode-hook - dired-load-hook - -Keybindings: -\\{dired-mode-map}" - ;; Not to be called interactively (e.g. dired-directory will be set - ;; to default-directory, which is wrong with wildcards). - (kill-all-local-variables) - (use-local-map dired-mode-map) - (dired-advertise) ; default-directory is already set - (setq major-mode 'dired-mode - mode-name "Dired" - case-fold-search nil - buffer-read-only t - selective-display t ; for subdirectory hiding - 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) - "\n\n") - (set (make-local-variable 'dired-directory) - (or dirname default-directory)) - (set (make-local-variable 'list-buffers-directory) - dired-directory) - (set (make-local-variable 'dired-actual-switches) - (or switches dired-listing-switches)) - (make-local-variable 'dired-sort-mode) - (dired-sort-other dired-actual-switches t) - (run-hooks 'dired-mode-hook)) - - -(defun dired-check-ls-l () - (let (case-fold-search) - (or (string-match "l" dired-actual-switches) - (error "Dired needs -l in ls switches")))) - -(defun dired-repeat-over-lines (arg function) - ;; This version skips non-file lines. - (beginning-of-line) - (while (and (> arg 0) (not (eobp))) - (setq arg (1- arg)) - (beginning-of-line) - (while (and (not (eobp)) (dired-between-files)) (forward-line 1)) - (save-excursion (funcall function)) - (forward-line 1)) - (while (and (< arg 0) (not (bobp))) - (setq arg (1+ arg)) - (forward-line -1) - (while (and (not (bobp)) (dired-between-files)) (forward-line -1)) - (beginning-of-line) - (save-excursion (funcall function)) - (dired-move-to-filename)) - (dired-move-to-filename)) - -(defun dired-flag-file-deleted (arg) - "In dired, flag the current line's file for deletion. -With prefix arg, repeat over several lines. - -If on a subdir headerline, mark all its files except `.' and `..'." - (interactive "P") - (let ((dired-marker-char dired-del-marker)) - (dired-mark-subdir-or-file arg))) - -(defun dired-quit () - "Bury the current dired buffer." - (interactive) - (bury-buffer)) - -(defun dired-summary () - (interactive) - ;>> this should check the key-bindings and use substitute-command-keys if non-standard - (message - "d-elete, u-ndelete, x-punge, f-ind, o-ther window, r-ename, c-opy, h-elp")) - -(defun dired-create-directory (directory) - "Create a directory called DIRECTORY." - (interactive - (list (read-file-name "Create directory: " (dired-current-directory)))) - (let ((expanded (directory-file-name (expand-file-name directory)))) - (make-directory expanded) - (dired-add-file expanded) - (dired-move-to-filename))) - -(defun dired-undo () - "Undo in a dired buffer. -This doesn't recover lost files, it is just normal undo with temporarily -writeable buffer. You can use it to recover marks, killed lines or subdirs. -In the latter case, you have to do \\[dired-build-subdir-alist] to -parse the buffer again." - (interactive) - (let (buffer-read-only) - (undo))) - -(defun dired-unflag (arg) - "In dired, remove the current line's delete flag then move to next line. -Optional prefix ARG says how many lines to unflag." - (interactive "p") - (dired-repeat-over-lines arg - '(lambda () - (let (buffer-read-only) - (delete-char 1) - (insert " ") - (forward-char -1) - nil)))) - -(defun dired-backup-unflag (arg) - "In dired, move up lines and remove deletion flag there. -Optional prefix ARG says how many lines to unflag; default is one line." - (interactive "p") - (dired-unflag (- arg))) - -(defun dired-next-line (arg) - "Move down lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (next-line arg) - (dired-move-to-filename)) - -(defun dired-previous-line (arg) - "Move up lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (previous-line arg) - (dired-move-to-filename)) - -(defun dired-up-directory () - "Run dired on parent directory of current directory. -Find the parent directory either in this buffer or another buffer. -Creates a buffer if necessary." - (interactive) - (let* ((dir (dired-current-directory)) - (up (file-name-directory (directory-file-name dir)))) - (or (dired-goto-file (directory-file-name dir)) - (dired-goto-subdir up) - (progn - (dired up) - (dired-goto-file dir))))) - -(defun dired-find-file () - "In dired, visit the file or directory named on this line." - (interactive) - (let ((find-file-run-dired t)) - (find-file (dired-get-filename)))) - -(defun dired-view-file () - "In dired, examine a file in view mode, returning to dired when done. -When file is a directory, show it in this buffer if it is inserted; -otherwise, display it in another buffer." - (interactive) - (if (file-directory-p (dired-get-filename)) - (or (dired-goto-subdir (dired-get-filename)) - (dired (dired-get-filename))) - (view-file (dired-get-filename)))) - -(defun dired-find-file-other-window () - "In dired, visit this file or directory in another window." - (interactive) - (let ((find-file-run-dired t)) ;; XEmacs - (find-file-other-window (dired-get-filename)))) - -(defun dired-get-filename (&optional localp no-error-if-not-filep) - "In dired, return name of file mentioned on this line. -Value returned normally includes the directory name. -Optional arg LOCALP with value `no-dir' means don't include directory - name in result. A value of t means use path name relative to - `default-directory', which still may contain slashes if in a subdirectory. -Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on - this line, otherwise an error occurs." - (let (case-fold-search file p1 p2) - (save-excursion - (if (setq p1 (dired-move-to-filename (not no-error-if-not-filep))) - (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep)))) - ;; nil if no file on this line, but no-error-if-not-filep is t: - (if (setq file (and p1 p2 (buffer-substring p1 p2))) - ;; Check if ls quoted the names, and unquote them. - ;; Using read to unquote is much faster than substituting - ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. - (cond ((string-match "b" dired-actual-switches) ; System V ls - ;; This case is about 20% slower than without -b. - (setq file - (read - (concat "\"" - ;; some ls -b don't escape quotes, argh! - ;; This is not needed for GNU ls, though. - (or (dired-string-replace-match - "\\([^\\]\\)\"" file "\\1\\\\\"") - file) - "\"")))) - ;; If you do this, update dired-insert-subdir-validate too - ;; ((string-match "Q" dired-actual-switches) ; GNU ls - ;; (setq file (read file))) - )) - (if (eq localp 'no-dir) - file - (and file (concat (dired-current-directory localp) file))))) - -(defun dired-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the UNIX version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (string-match "l" dired-actual-switches) - (if (re-search-forward - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+" - eol t) - (progn - (skip-chars-forward " ") ; there is one SPC after day of month - (skip-chars-forward "^ " eol) ; move after time of day (or year) - (skip-chars-forward " " eol) ; there is space before the file name - ;; Actually, if the year instead of clock time is displayed, - ;; there are (only for some ls programs?) two spaces instead - ;; of one before the name. - ;; If we could depend on ls inserting exactly one SPC we - ;; would not bomb on names _starting_ with SPC. - (point)) - (if raise-error - (error "No file on this line") - nil)) - ;; else ls switches don't contain -l. - ;; Note that even if we make dired-move-to-filename and - ;; dired-move-to-end-of-filename (and thus dired-get-filename) - ;; work, all commands that gleaned information from the permission - ;; bits (like dired-mark-directories) will cease to work properly. - (if (eolp) - (if raise-error - (error "No file on this line") - nil) - ;; skip marker, if any - (forward-char)) - (skip-chars-forward " ") - (point))) - -(defun dired-move-to-end-of-filename (&optional no-error) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - ;; This is the UNIX version. - (let (opoint file-type executable symlink hidden case-fold-search used-F eol) - ;; case-fold-search is nil now, so we can test for capital F: - (setq used-F (string-match "F" dired-actual-switches) - opoint (point) - eol (save-excursion (end-of-line) (point)) - hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (save-excursion;; Find out what kind of file this is: - ;; Restrict perm bits to be non-blank, - ;; otherwise this matches one char to early (looking backward): - ;; "l---------" (some systems make symlinks that way) - ;; "----------" (plain file with zero perms) - (if (re-search-backward - "\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)" - nil t) - (setq file-type (char-after (match-beginning 1)) - symlink (eq file-type ?l) - ;; Only with -F we need to know whether it's an executable - executable (and - used-F - (string-match - "[xst]";; execute bit set anywhere? - (concat - (buffer-substring (match-beginning 2) - (match-end 2)) - (buffer-substring (match-beginning 3) - (match-end 3)) - (buffer-substring (match-beginning 4) - (match-end 4)))))) - (or no-error - (not (string-match "l" dired-actual-switches)) - (error "No file on this line")))) - ;; Move point to end of name: - (if symlink - (if (search-forward " ->" eol t) - (progn - (forward-char -3) - (and used-F - dired-ls-F-marks-symlinks - (eq (preceding-char) ?@);; did ls really mark the link? - (forward-char -1)))) - (goto-char eol);; else not a symbolic link - ;; ls -lF marks dirs, sockets and executables with exactly one - ;; trailing character. (Executable bits on symlinks ain't mean - ;; a thing, even to ls, but we know it's not a symlink.) - (and used-F - ;; -F may not actually be honored, e.g. by an FTP ls in ange-ftp - (let ((char (preceding-char))) - (or (and (eq file-type ?d) (eq char ?/)) - (and executable (eq char ?*)) - (and (eq file-type ?s) (eq char ?=)))) - (forward-char -1)))) - (or no-error - (not (eq opoint (point))) - (error (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - - -;; Perhaps something could be done to handle VMS' own backups. - -(defun dired-clean-directory (keep) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." - (interactive "P") - (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) - (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - (late-retention (if (<= keep 0) dired-kept-versions keep)) - (file-version-assoc-list ())) - (message "Cleaning numerical backups (keeping %d late, %d old)..." - late-retention early-retention) - ;; Look at each file. - ;; If the file has numeric backup versions, - ;; put on file-version-assoc-list an element of the form - ;; (FILENAME . VERSION-NUMBER-LIST) - (dired-map-dired-file-lines (function dired-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions not to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines (function dired-trample-file-versions)) - (message "Cleaning numerical backups...done"))) - -;;; Subroutines of dired-clean-directory. - -(defun dired-map-dired-file-lines (fun) - ;; Perform FUN with point at the end of each non-directory line. - ;; FUN takes one argument, the filename (complete pathname). - (dired-check-ls-l) - (save-excursion - (let (file buffer-read-only) - (goto-char (point-min)) - (while (not (eobp)) - (save-excursion - (and (not (looking-at dired-re-dir)) - (not (eolp)) - (setq file (dired-get-filename nil t)) ; nil on non-file - (progn (end-of-line) - (funcall fun file)))) - (forward-line 1))))) - -(defun dired-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar 'backup-extract-version possibilities))) - (if versions - (setq file-version-assoc-list (cons (cons fn versions) - file-version-assoc-list))))) - -(defun dired-trample-file-versions (fn) - (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) - base-version-list) - (and start-vn - (setq base-version-list ; there was a base version to which - (assoc (substring fn 0 start-vn) ; this looks like a - file-version-assoc-list)) ; subversion - (not (memq (string-to-int (substring fn (+ 2 start-vn))) - base-version-list)) ; this one doesn't make the cut - (progn (beginning-of-line) - (delete-char 1) - (insert dired-del-marker))))) - - -;; Keeping Dired buffers in sync with the filesystem and with each other - -(defvar dired-buffers nil - ;; Enlarged by dired-advertise - ;; Queried by function dired-buffers-for-dir. When this detects a - ;; killed buffer, it is removed from this list. - "Alist of directories and their associated dired buffers.") - -(defun dired-buffers-for-dir (dir) -;; Return a list of buffers that dired DIR (top level or in-situ subdir). -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist)) - (if (dired-in-this-tree dir (car elt)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (assoc dir (save-excursion - (set-buffer buf) - dired-subdir-alist)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - (setq alist (cdr alist))) - result)) - -(defun dired-advertise () - ;;"Advertise in variable `dired-buffers' that we dired `default-directory'." - ;; With wildcards we actually advertise too much. - (if (memq (current-buffer) (dired-buffers-for-dir default-directory)) - t ; we have already advertised ourselves - (setq dired-buffers - (cons (cons default-directory (current-buffer)) - dired-buffers)))) - -(defun dired-unadvertise (dir) - ;; Remove DIR from the buffer alist in variable dired-buffers. - ;; This has the effect of removing any buffer whose main directory is DIR. - ;; It does not affect buffers in which DIR is a subdir. - ;; Removing is also done as a side-effect in dired-buffer-for-dir. - (setq dired-buffers - (delq (assoc dir dired-buffers) dired-buffers))) - -(defun dired-fun-in-all-buffers (directory fun &rest args) - ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. - ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let ((buf-list (dired-buffers-for-dir directory)) - (obuf (current-buffer)) - buf success-list) - (while buf-list - (setq buf (car buf-list) - buf-list (cdr buf-list)) - (unwind-protect - (progn - (set-buffer buf) - (if (apply fun args) - (setq success-list (cons (buffer-name buf) success-list)))) - (set-buffer obuf))) - success-list)) - -(defun dired-add-file (filename &optional marker-char) - (dired-fun-in-all-buffers - (file-name-directory filename) - (function dired-add-entry) filename marker-char)) - -(defun dired-add-entry (filename &optional marker-char) - ;; Add a new entry for FILENAME, optionally marking it - ;; with MARKER-CHAR (a character, else dired-marker-char is used). - ;; Note that this adds the entry `out of order' if files sorted by - ;; time, etc. - ;; At least this version inserts in the right subdirectory (if present). - ;; And it skips "." or ".." (see `dired-trivial-filenames'). - ;; Hidden subdirs are exposed if a file is added there. - (setq filename (directory-file-name filename)) - ;; Entry is always for files, even if they happen to also be directories - (let ((opoint (point)) - (cur-dir (dired-current-directory)) - (directory (file-name-directory filename)) - reason) - (setq filename (file-name-nondirectory filename) - reason - (catch 'not-found - (if (string= directory cur-dir) - (progn - (if (dired-subdir-hidden-p cur-dir) - (dired-unhide-subdir)) - ;; We are already where we should be, except when - ;; point is before the subdir line or its total line. - (let ((p (dired-after-subdir-garbage cur-dir))) - (if (< (point) p) - (goto-char p)))) - ;; else try to find correct place to insert - (if (dired-goto-subdir directory) - (progn;; unhide if necessary - (if (looking-at "\r");; point is at end of subdir line - (dired-unhide-subdir)) - ;; found - skip subdir and `total' line - ;; and uninteresting files like . and .. - ;; This better not moves into the next subdir! - (dired-goto-next-nontrivial-file)) - ;; not found - (throw 'not-found "Subdir not found"))) - ;; found and point is at The Right Place: - (let (buffer-read-only) - (beginning-of-line) - (dired-add-entry-do-indentation marker-char) - (dired-ls (dired-make-absolute filename directory);; don't expand `.' ! - (concat dired-actual-switches "d")) - (forward-line -1) - ;; We want to have the non-directory part, only: - (let* ((beg (dired-move-to-filename t)) ; error for strange output - (end (dired-move-to-end-of-filename))) - (setq filename (buffer-substring beg end)) - (delete-region beg end) - (insert (file-name-nondirectory filename))) - (if dired-after-readin-hook;; the subdir-alist is not affected... - (save-excursion;; ...so we can run it right now: - (save-restriction - (beginning-of-line) - (narrow-to-region (point) (save-excursion - (forward-line 1) (point))) - (run-hooks 'dired-after-readin-hook)))) - (dired-move-to-filename)) - ;; return nil if all went well - nil)) - (if reason ; don't move away on failure - (goto-char opoint)) - (not reason))) ; return t on succes, nil else - -;; This is a separate function for the sake of nested dired format. -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space: - (insert (if marker-char - (if (integerp marker-char) marker-char dired-marker-char) - ?\040) - ?\040)) - -(defun dired-after-subdir-garbage (dir) - ;; Return pos of first file line of DIR, skipping header and total - ;; or wildcard lines. - ;; Important: never moves into the next subdir. - ;; DIR is assumed to be unhidden. - ;; Will probably be redefined for VMS etc. - (save-excursion - (or (dired-goto-subdir dir) (error "This cannot happen")) - (forward-line 1) - (while (and (not (eolp)) ; don't cross subdir boundary - (not (dired-move-to-filename))) - (forward-line 1)) - (point))) - -(defun dired-remove-file (file) - (dired-fun-in-all-buffers - (file-name-directory file) (function dired-remove-entry) file)) - -(defun dired-remove-entry (file) - (save-excursion - (and (dired-goto-file file) - (let (buffer-read-only) - (delete-region (progn (beginning-of-line) (point)) - (save-excursion (forward-line 1) (point))))))) - -(defun dired-relist-file (file) - (dired-fun-in-all-buffers (file-name-directory file) - (function dired-relist-entry) file)) - -(defun dired-relist-entry (file) - ;; Relist the line for FILE, or just add it if it did not exist. - ;; FILE must be an absolute pathname. - (let (buffer-read-only marker) - ;; If cursor is already on FILE's line delete-region will cause - ;; save-excursion to fail because of floating makers, - ;; moving point to beginning of line. Sigh. - (save-excursion - (and (dired-goto-file file) - (delete-region (progn (beginning-of-line) - (setq marker (following-char)) - (point)) - (save-excursion (forward-line 1) (point)))) - (setq file (directory-file-name file)) - (dired-add-entry file (if (eq ?\040 marker) nil marker))))) - -(defun dired-update-file-line (file) - ;; Delete the current line, and insert an entry for FILE. - ;; If FILE is nil, then just delete the current line. - ;; Keeps any marks that may be present in column one (doing this - ;; here is faster than with dired-add-entry's optional arg). - ;; Does not update other dired buffers. Use dired-relist-entry for that. - (beginning-of-line) - (let ((char (following-char)) (opoint (point))) - (delete-region (point) (progn (forward-line 1) (point))) - (if file - (progn - (dired-add-entry file) - ;; Replace space by old marker without moving point. - ;; Faster than goto+insdel inside a save-excursion? - (subst-char-in-region opoint (1+ opoint) ?\040 char)))) - (dired-move-to-filename)) - - -;; Running subprocesses, checking and logging of their errors. - -(defvar dired-log-buf "*Dired log*") - -(defun dired-why () - "Pop up a buffer with error log output from Dired. -A group of errors from a single command ends with a formfeed. -Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) - (let ((obuf (current-buffer))) - (pop-to-buffer dired-log-buf) - (goto-char (point-max)) - (recenter -1) - (switch-to-buffer-other-window obuf))) - -(defun dired-log (log &rest args) - ;; Log a message or the contents of a buffer. - ;; If LOG is a string and there are more args, it is formatted with - ;; those ARGS. Usually the LOG string ends with a \n. - ;; End each bunch of errors with (dired-log t): this inserts - ;; current time and buffer, and a \f (formfeed). - (let ((obuf (current-buffer))) - (unwind-protect ; want to move point - (progn - (set-buffer (get-buffer-create dired-log-buf)) - (goto-char (point-max)) - (let (buffer-read-only) - (cond ((stringp log) - (insert (if args - (apply (function format) log args) - log))) - ((bufferp log) - (insert-buffer log)) - ((eq t log) - (insert "\n\t" (current-time-string) - "\tBuffer `" (buffer-name obuf) "'\n\f\n"))))) - (set-buffer obuf)))) - -(defun dired-log-summary (log &rest args) - ;; Log a summary describing a bunch of errors. - (apply (function dired-log) (concat "\n" log) args) - (dired-log t)) - -;; In Emacs 19 this will return program's exit status. -;; This is a separate function so that ange-ftp can redefine it. -(defun dired-call-process (program discard &rest arguments) -; "Run PROGRAM with output to current buffer unless DISCARD is t. -;Remaining arguments are strings passed as command arguments to PROGRAM." - (apply 'call-process program nil (not discard) nil arguments)) - -(defun dired-check-process-checker (exit-status) - ;; In Emacs 19, EXIT-STATUS comes from (dired-)call-process - ;; Then this function should return (/= 0 exit-status) - ;; In Emacs 18 the exit status is not accessible, so we - ;; do the following which is not always correct as some compress - ;; programs are verbose by default or otherwise braindamaged - (if (and dired-emacs-19-p exit-status) - (/= 0 exit-status);; #### install (does it work in Emacs 19?) - (/= 0 (buffer-size))) ; run in program's output buffer - ;; If have you one of those compress programs, you might - ;; want to redefine this function to look closer at compress' output. - ;; This is why it is a separate function. - ) - -(defun dired-check-process (msg program &rest arguments) -; "Display MSG while running PROGRAM, and check for output. -;Remaining arguments are strings passed as command arguments to PROGRAM. -; On error as determined by dired-check-process-checker, insert output -; in a log buffer and return the offending ARGUMENTS or PROGRAM. -; Caller can cons up a list of failed args. -;Else returns nil for success." - (let (err-buffer err (dir default-directory)) - (message "%s..." msg) - (save-excursion - ;; Get a clean buffer for error output: - (setq err-buffer (get-buffer-create " *dired-check-process output*")) - (set-buffer err-buffer) - (erase-buffer) - (setq default-directory dir ; caller's default-directory - err (dired-check-process-checker - (apply (function dired-call-process) program nil arguments))) - (if err - (progn - (dired-log (concat program " " (prin1-to-string arguments) "\n")) - (dired-log err-buffer) - (or arguments program t)) - (kill-buffer err-buffer) - (message "%s...done" msg) - nil)))) - -;;; 7K -;;;###begin dired-cmd.el -;; Diffing and compressing - -(defun dired-diff (file &optional switches) - "Compare file at point with file FILE using `diff'. -FILE defaults to the file at the mark. -The prompted-for file is the first file given to `diff'. -Prefix arg lets you edit the diff switches. See the command `diff'." - (interactive - (let ((default (if (mark) - (save-excursion (goto-char (mark)) - (dired-get-filename t t))))) - (list (read-file-name (format "Diff %s with: %s" - (dired-get-filename t) - (if default - (concat "(default " default ") ") - "")) - (dired-current-directory) default t) - (if (fboundp 'diff-read-switches) - (diff-read-switches "Options for diff: "))))) - (if switches ; Emacs 19's diff has but two - (diff file (dired-get-filename t) switches) ; args (yet ;-) - (diff file (dired-get-filename t)))) - -(defun dired-backup-diff (&optional switches) - "Diff this file with its backup file or vice versa. -Uses the latest backup, if there are several numerical backups. -If this file is a backup, diff it with its original. -The backup file is the first file given to `diff'. -Prefix arg lets you edit the diff switches. See the command `diff'." - (interactive (list (if (fboundp 'diff-read-switches) - (diff-read-switches "Diff with switches: ")))) - (let (bak ori (file (dired-get-filename))) - (if (backup-file-name-p file) - (setq bak file - ori (file-name-sans-versions file)) - (setq bak (or (latest-backup-file file) - (error "No backup found for %s" file)) - ori file)) - (if switches - (diff bak ori switches) - (diff bak ori)))) - -;;#### install (move this function into files.el) -(defun latest-backup-file (fn) ; actually belongs into files.el - "Return the latest existing backup of FILE, or nil." - ;; First try simple backup, then the highest numbered of the - ;; numbered backups. - ;; Ignore the value of version-control because we look for existing - ;; backups, which maybe were made earlier or by another user with - ;; a different value of version-control. - (setq fn (expand-file-name fn)) - (or - (let ((bak (make-backup-file-name fn))) - (if (file-exists-p bak) bak)) - (let* ((dir (file-name-directory fn)) - (base-versions (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions))) - (concat dir - (car (sort - (file-name-all-completions base-versions dir) - ;; bv-length is a fluid var for backup-extract-version: - (function - (lambda (fn1 fn2) - (> (backup-extract-version fn1) - (backup-extract-version fn2)))))))))) - -;; This is a separate function for the sake of ange-ftp.el -(defun dired-compress-make-compressed-filename (from-file &optional reverse) -;; "Converts a filename FROM-FILE to the filename of the associated -;; compressed file. With an optional argument REVERSE, the reverse -;; conversion is done." - - (if reverse - - ;; uncompress... - ;; return `nil' if no match found -- better than nothing - (let (case-fold-search ; case-sensitive search - (string - (concat "\\.\\(g?z\\|" (regexp-quote dired-gzip-file-extension) - "$\\|Z\\)$"))) - - (and (string-match string from-file) - (substring from-file 0 (match-beginning 0)))) - - ;; compress... - ;; note: it could be that `gz' is not the proper extension for gzip - (concat from-file - (if dired-use-gzip-instead-of-compress - dired-gzip-file-extension ".Z")))) - - -(defun dired-compress () - ;; Compress current file. Return nil for success, offending filename else. - (dired-check-ls-l) - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (dired-compress-make-compressed-filename from-file))) - (cond ((save-excursion (beginning-of-line) - (looking-at dired-re-sym)) - (dired-log (concat "Attempt to compress a symbolic link:\n" - from-file)) - (dired-make-relative from-file)) - ( - - (if dired-use-gzip-instead-of-compress - ;; gzip (GNU zip) - ;; use `-q' (quiet) switch for gzip in case GZIP environment - ;; variable contains `--verbose' - lrd - Feb 18, 1993 - (dired-check-process (concat "Gzip'ing " from-file) - "gzip" "--quiet" "--force" "--suffix" - dired-gzip-file-extension from-file) - - (dired-check-process (concat "Compressing " from-file) - "compress" "-f" from-file)) - ;; errors from the process are already logged by dired-check-process - (dired-make-relative from-file)) - (t - (dired-update-file-line to-file) - nil)))) - -(defun dired-uncompress () - ;; Uncompress current file. Return nil for success, offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (dired-compress-make-compressed-filename from-file t))) - (if - (if dired-use-gzip-instead-of-compress - ;; gzip (GNU zip) - ;; use `-q' (quiet) switch for gzip in case GZIP environment - ;; variable contains `--verbose' - lrd - Feb 18, 1993 - (dired-check-process (concat "Gunzip'ing " from-file) - "gzip" "--decompress" "--quiet" "--suffix" - dired-gzip-file-extension from-file) - - (dired-check-process (concat "Uncompressing " from-file) - "uncompress" from-file)) - - (dired-make-relative from-file) - (dired-update-file-line to-file) - nil))) - -(defun dired-mark-map-check (fun arg op-symbol &optional show-progress) -; "Map FUN over marked files (with second ARG like in dired-mark-map) -; and display failures. - -; FUN takes zero args. It returns non-nil (the offending object, e.g. -; the short form of the filename) for a failure and probably logs a -; detailed error explanation using function `dired-log'. - -; OP-SYMBOL is a symbol describing the operation performed (e.g. -; `compress'). It is used with `dired-mark-pop-up' to prompt the user -; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. -; `Failed to compress 1 of 2 files - type W to see why ("foo")') - -; SHOW-PROGRESS if non-nil means redisplay dired after each file." - (if (dired-mark-confirm op-symbol arg) - (let* ((total-list;; all of FUN's return values - (dired-mark-map (funcall fun) arg show-progress)) - (total (length total-list)) - (failures (delq nil total-list)) - (count (length failures))) - (if (not failures) - (message "%s: %d file%s." - (capitalize (symbol-name op-symbol)) - total (dired-plural-s total)) - (message "Failed to %s %d of %d file%s - type W to see why %s" - (symbol-name op-symbol) count total (dired-plural-s total) - ;; this gives a short list of failed files in parens - ;; which may be sufficient for the user even - ;; without typing `W' for the process' diagnostics - failures) - ;; end this bunch of errors: - (dired-log-summary - "Failed to %s %d of %d file%s" - (symbol-name op-symbol) count total (dired-plural-s total)))))) - -(defun dired-do-compress (&optional arg) - "Compress marked (or next ARG) files. -Type \\[dired-do-uncompress] to uncompress again." - (interactive "P") - (dired-mark-map-check (function dired-compress) arg 'compress t)) - -(defun dired-do-uncompress (&optional arg) - "Uncompress marked (or next ARG) files." - (interactive "P") - (dired-mark-map-check (function dired-uncompress) arg 'uncompress t)) - -;; Commands for Emacs Lisp files - load and byte compile - -(defun dired-byte-compile () - ;; Return nil for success, offending file name else. - (let* ((filename (dired-get-filename)) - (elc-file - (if (eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c") - (concat filename "c"))) - buffer-read-only failure) - (condition-case err - (save-excursion (byte-compile-file filename)) - (error - (setq failure err))) - (if failure - (progn - (dired-log "Byte compile error for %s:\n%s\n" filename failure) - (dired-make-relative filename)) - (dired-remove-file elc-file) - (forward-line) ; insert .elc after its .el file - (dired-add-file elc-file) - nil))) - -(defun dired-do-byte-compile (&optional arg) - "Byte compile marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-mark-map-check (function dired-byte-compile) arg 'byte-compile t)) - -(defun dired-load () - ;; Return nil for success, offending file name else. - (let ((file (dired-get-filename)) failure) - (condition-case err - (load file nil nil t) - (error (setq failure err))) - (if (not failure) - nil - (dired-log "Load error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(defun dired-do-load (&optional arg) - "Load the marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-mark-map-check (function dired-load) arg 'load t)) - -(defun dired-do-chxxx (attribute-name program op-symbol arg) - ;; Change file attributes (mode, group, owner) of marked files and - ;; refresh their file lines. - ;; ATTRIBUTE-NAME is a string describing the attribute to the user. - ;; PROGRAM is the program used to change the attribute. - ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). - ;; ARG describes which files to use, like in dired-mark-get-files. - (let* ((files (dired-mark-get-files t arg)) - (new-attribute - (dired-mark-read-string - (concat "Change " attribute-name " of %s to: ") - nil op-symbol arg files)) - (operation (concat program " " new-attribute)) - (failure (apply (function dired-check-process) - operation program new-attribute - files))) - (dired-do-redisplay arg);; moves point if ARG is an integer - (if failure - (dired-log-summary - (message "%s: error - type W to see why." operation))))) - -(defun dired-do-chmod (&optional arg) - "Change the mode of the marked (or next ARG) files. -This calls chmod, thus symbolic modes like `g+w' are allowed." - (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) - -(defun dired-do-chgrp (&optional arg) - "Change the group of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) - -(defun dired-do-chown (&optional arg) - "Change the owner of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) - -;;;###end dired-cmd.el - - -;; Deleting files - -;; #### called dired-do-flagged-delete in FSF -(defun dired-do-deletions (&optional nomessage) - "In dired, delete the files flagged for deletion. -If NOMESSAGE is non-nil, we don't display any message -if there are no flagged files." - (interactive) - (let* ((dired-marker-char dired-del-marker) - (regexp (dired-marker-regexp)) - case-fold-search) - (if (save-excursion (goto-char (point-min)) - (re-search-forward regexp nil t)) - (dired-internal-do-deletions - ;; this can't move point since ARG is nil - (dired-mark-map (cons (dired-get-filename) (point)) - nil) - nil) - (or nomessage - (message "(No deletions requested)"))))) - -(defun dired-do-delete (&optional arg) - "Delete all marked (or next ARG) files." - ;; This is more consistent with the file marking feature than - ;; dired-do-deletions. - (interactive "P") - (dired-internal-do-deletions - ;; this may move point if ARG is an integer - (dired-mark-map (cons (dired-get-filename) (point)) - arg) - arg)) - -(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? - -(defun dired-internal-do-deletions (l arg) - ;; L is an alist of files to delete, with their buffer positions. - ;; ARG is the prefix arg. - ;; Filenames are absolute (VMS needs this for logical search paths). - ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. - ;; That way as changes are made in the buffer they do not shift the - ;; lines still to be changed, so the (point) values in L stay valid. - ;; Also, for subdirs in natural order, a subdir's files are deleted - ;; before the subdir itself - the other way around would not work. - (let ((files (mapcar (function car) l)) - (count (length l)) - (succ 0)) - ;; canonicalize file list for pop up - (setq files (nreverse (mapcar (function dired-make-relative) files))) - (if (dired-mark-pop-up - " *Deletions*" 'delete files dired-deletion-confirmer - (format "Delete %s " (dired-mark-prompt arg files))) - (save-excursion - (let (failures);; files better be in reverse order for this loop! - (while l - (goto-char (cdr (car l))) - (let (buffer-read-only) - (condition-case err - (let ((fn (car (car l)))) - ;; This test is equivalent to - ;; (and (file-directory-p fn) (not (file-symlink-p fn))) - ;; but more efficient - (if (eq t (car (file-attributes fn))) - (remove-directory fn) - (delete-file fn)) - ;; if we get here, removing worked - (setq succ (1+ succ)) - (message "%s of %s deletions" succ count) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) - (dired-clean-up-after-deletion fn)) - (error;; catch errors from failed deletions - (dired-log "%s\n" err) - (setq failures (cons (car (car l)) failures))))) - (setq l (cdr l))) - (if (not failures) - (message "%d deletion%s done" count (dired-plural-s count)) - (dired-log-summary - (message "%d of %d deletion%s failed: %s" - (length failures) count - (dired-plural-s count) - (prin1-to-string failures)))))) - (message "(No deletions performed)"))) - (dired-move-to-filename)) - -;; This is a separate function for the sake of dired-x.el. -(defun dired-clean-up-after-deletion (fn) - ;; Clean up after a deleted file or directory FN. - (save-excursion (and (dired-goto-subdir fn) - (dired-kill-subdir)))) - - -(defun dired-replace-in-string (regexp newtext string) - ;; Replace REGEXP with NEWTEXT everywhere in STRING and return result. - ;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized. - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result (substring string start mb) newtext) - start me)) - (concat result (substring string start)))) - -(defun dired-next-dirline (arg &optional opoint) - "Goto ARG'th next directory file line." - (interactive "_p") - (dired-check-ls-l) - (or opoint (setq opoint (point))) - (if (if (> arg 0) - (re-search-forward dired-re-dir nil t arg) - (beginning-of-line) - (re-search-backward dired-re-dir nil t (- arg))) - (dired-move-to-filename) ; user may type `i' or `f' - (goto-char opoint) - (error "No more subdirectories"))) - -(defun dired-prev-dirline (arg) - "Goto ARG'th previous directory file line." - (interactive "_p") - (dired-next-dirline (- arg))) - -(defun dired-unflag-all-files (flag &optional arg) - "Remove a specific or all flags from every file. -With an arg, queries for each marked file. -Type \\[help-command] at that time for help." - (interactive "sRemove flag: (default: all flags) \nP") - (let ((count 0) - (re (if (zerop (length flag)) dired-re-mark - (concat "^" (regexp-quote flag))))) - (save-excursion - (let (buffer-read-only case-fold-search query - (help-form "\ -Type SPC or `y' to unflag one file, DEL or `n' to skip to next, -`!' to unflag all remaining files with no more questions.")) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (if (or (not arg) - (dired-query 'query "Unflag file `%s' ? " - (dired-get-filename t))) - (progn (delete-char -1) (insert " ") (setq count (1+ count)))) - (forward-line 1)))) - (message "%s" (format "Flags removed: %d %s" count flag) ))) - -;; pop ups and user input for file marking - -(defun dired-marker-regexp () - (concat "^" (regexp-quote (char-to-string dired-marker-char)))) - -(defun dired-plural-s (count) - (if (= 1 count) "" "s")) - -(defun dired-mark-prompt (arg files) - ;; Return a string for use in a prompt, either the current file - ;; name, or the marker and a count of marked files. - (let ((count (length files))) - (if (= count 1) - (car files) - ;; more than 1 file: - (if (integerp arg) - ;; abs(arg) = count - ;; Perhaps this is nicer, but it also takes more screen space: - ;;(format "[%s %d files]" (if (> arg 0) "next" "previous") - ;; count) - (format "[next %d files]" arg) - (format "%c [%d files]" dired-marker-char count))))) - -(defvar dired-query-alist - '((?\y . y) (?\040 . y) ; `y' or SPC means accept once - (?n . n) (?\177 . n) ; `n' or DEL skips once - (?! . yes) ; `!' accepts rest - (?q. no) (?\e . no) ; `q' or ESC skips rest - ;; None of these keys quit - use C-g for that. - )) - -(defun dired-query (qs-var qs-prompt &rest qs-args) - ;; Query user and return nil or t. - ;; Store answer in symbol VAR (which must initially be bound to nil). - ;; Format PROMPT with ARGS. - ;; Binding variable help-form will help the user who types C-h. - (let* ((char (symbol-value qs-var)) - (action (cdr (assoc char dired-query-alist)))) - (cond ((eq 'yes action) - t) ; accept, and don't ask again - ((eq 'no action) - nil) ; skip, and don't ask again - (t;; no lasting effects from last time we asked - ask now - (let ((qprompt (concat qs-prompt - (if help-form - (format " [Type yn!q or %s] " - (key-description - (char-to-string help-char))) - " [Type y, n, q or !] "))) - result elt) - ;; Actually it looks nicer without cursor-in-echo-area - you can - ;; look at the dired buffer instead of at the prompt to decide. - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char))) - (while (not (setq elt (assoc char dired-query-alist))) - (message "Invalid char - type %c for help." help-char) - (ding) - (sit-for 1) - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char)))) - (memq (cdr elt) '(t y yes))))))) - -(defun dired-pop-to-buffer (buf) - ;; Pop up buffer BUF. - ;; If dired-shrink-to-fit is t, make its window fit its contents. - (if (not dired-shrink-to-fit) - (pop-to-buffer (get-buffer-create buf)) - ;; let window shrink to fit: - (let ((window (selected-window)) - target-lines w2) - (cond ;; if split-window-threshold is enabled, use the largest window - ((and (> (window-height (setq w2 (get-largest-window))) - split-height-threshold) - (= (screen-width) (window-width w2))) - (setq window w2)) - ;; if the least-recently-used window is big enough, use it - ((and (> (window-height (setq w2 (get-lru-window))) - (* 2 window-min-height)) - (= (screen-width) (window-width w2))) - (setq window w2))) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (skip-chars-backward "\n\r\t ") - (setq target-lines (count-lines (point-min) (point)))) - (if (<= (window-height window) (* 2 window-min-height)) - ;; At this point, every window on the screen is too small to split. - (setq w2 (display-buffer buf)) - (setq w2 (split-window window - (max window-min-height - (- (window-height window) - (1+ (max window-min-height target-lines))))))) - (set-window-buffer w2 buf) - (if (< (1- (window-height w2)) target-lines) - (progn - (select-window w2) - (enlarge-window (- target-lines (1- (window-height w2)))))) - (set-window-start w2 1) - ))) - -(defvar dired-no-confirm nil -;; "If non-nil, list of symbols for commands dired should not confirm. -;;It can be a sublist of -;; -;; '(byte-compile chgrp chmod chown compress copy delete hardlink load -;; move print shell symlink uncompress)" - ) - -(defun dired-mark-confirm (op-symbol arg) - ;; Request confirmation from the user that the operation described - ;; by OP-SYMBOL is to be performed on the marked files. - ;; Confirmation consists in a y-or-n question with a file list - ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. - ;; The files used are determined by ARG (like in dired-mark-get-files). - (or (memq op-symbol dired-no-confirm) - (let ((files (dired-mark-get-files t arg))) - (dired-mark-pop-up nil op-symbol files (function y-or-n-p) - (concat (capitalize (symbol-name op-symbol)) " " - (dired-mark-prompt arg files) "? "))))) - -(defun dired-mark-pop-up (bufname op-symbol files function &rest args) - ;;"Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. - ;;Return FUNCTION's result on ARGS after popping up a window (in a buffer - ;;named BUFNAME, nil gives \" *Marked Files*\") showing the marked - ;;files. Uses function `dired-pop-to-buffer' to do that. - ;; FUNCTION should not manipulate files. - ;; It should only read input (an argument or confirmation). - ;;The window is not shown if there is just one file or - ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. - ;;FILES is the list of marked files." - (or bufname (setq bufname " *Marked Files*")) - (if (or (memq op-symbol dired-no-confirm) - (= (length files) 1)) - (apply function args) - (save-excursion - (set-buffer (get-buffer-create bufname)) - (erase-buffer) - (dired-format-columns-of-files files)) - (save-window-excursion - (dired-pop-to-buffer bufname) - (apply function args)))) - -(defun dired-format-columns-of-files (files) - ;; Files should be in forward order for this loop. - ;; i.e., (car files) = first file in buffer. - ;; Returns the number of lines used. - (let* ((maxlen (+ 2 (apply 'max (mapcar 'length files)))) - (width (- (window-width (selected-window)) 2)) - (columns (max 1 (/ width maxlen))) - (nfiles (length files)) - (rows (+ (/ nfiles columns) - (if (zerop (% nfiles columns)) 0 1))) - (i 0) - (j 0)) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* columns rows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j rows) - (while (< i columns) - (indent-to (* i maxlen)) - (insert (car files)) - (setq files (nthcdr rows files) - i (1+ i))) - (insert "\n") - (setq i 0 - j (1+ j) - files (cdr files))) - rows)) - -;; Read arguments for a mark command of type OP-SYMBOL, -;; perhaps popping up the list of marked files. -;; ARG is the prefix arg and indicates whether the files came from -;; marks (ARG=nil) or a repeat factor (integerp ARG). -;; If the current file was used, the list has but one element and ARG -;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). - -(defun dired-mark-read-string (prompt initial op-symbol arg files) - ;; PROMPT for a string, with INITIAL input. - ;; Other args are used to give user feedback and pop-up: - ;; OP-SYMBOL of command, prefix ARG, marked FILES. - (dired-mark-pop-up - nil op-symbol files - (function read-string) - (format prompt (dired-mark-prompt arg files)) initial)) - -(defun dired-mark-read-file-name (prompt dir op-symbol arg files) - (dired-mark-pop-up - nil op-symbol files - (function read-file-name) - (format prompt (dired-mark-prompt arg files)) dir)) - -(defun dired-mark-file (arg) - "In dired, mark the current line's file for later commands. -With arg, repeat over several lines. -Use \\[dired-unflag-all-files] to remove all flags." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function (lambda () (delete-char 1) (insert dired-marker-char)))))) - -(defun dired-next-marked-file (arg &optional wrap opoint) - "Move to the next marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (or opoint (setq opoint (point)));; return to where interactively started - (if (if (> arg 0) - (re-search-forward dired-re-mark nil t arg) - (beginning-of-line) - (re-search-backward dired-re-mark nil t (- arg))) - (dired-move-to-filename) - (if (null wrap) - (progn - (goto-char opoint) - (error "No next marked file")) - (message "(Wraparound for next marked file)") - (goto-char (if (> arg 0) (point-min) (point-max))) - (dired-next-marked-file arg nil opoint)))) - -(defun dired-prev-marked-file (arg &optional wrap) - "Move to the previous marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (dired-next-marked-file (- arg) wrap)) - -(defun dired-file-marker (file) - ;; Return FILE's marker, or nil if unmarked. - (save-excursion - (and (dired-goto-file file) - (progn - (beginning-of-line) - (if (not (equal ?\040 (following-char))) - (following-char)))))) - -(defun dired-read-regexp (prompt &optional initial) -;; This is an extra function so that gmhist can redefine it. - (setq dired-flagging-regexp - (read-string prompt (or initial dired-flagging-regexp)))) - -(defun dired-mark-files-regexp (regexp &optional marker-char) - "Mark all files matching REGEXP for use in later commands. -A prefix argument means to unmark them instead. -`.' and `..' are never marked. - -REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for -object files--just `.o' will mark more than you might think." - (interactive - (list (dired-read-regexp (concat (if current-prefix-arg "Unmark" "Mark") - " files (regexp): ")) - (if current-prefix-arg ?\040))) - (let ((dired-marker-char (or marker-char dired-marker-char))) - (dired-mark-if - (and (not (looking-at dired-re-dot)) - (not (eolp)) ; empty line - (let ((fn (dired-get-filename nil t))) - (and fn (string-match regexp (file-name-nondirectory fn))))) - "matching file"))) - -(defun dired-flag-regexp-files (regexp) - "In dired, flag all files containing the specified REGEXP for deletion. -The match is against the non-directory part of the filename. Use `^' - and `$' to anchor matches. Exclude subdirs by hiding them. -`.' and `..' are never flagged." - (interactive (list (dired-read-regexp "Flag for deletion (regexp): "))) - (dired-mark-files-regexp regexp dired-del-marker)) - -(defun dired-mark-symlinks (unflag-p) - "Mark all symbolic links. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-sym) "symbolic link"))) - -(defun dired-mark-directories (unflag-p) - "Mark all directory file lines except `.' and `..'. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (and (looking-at dired-re-dir) - (not (looking-at dired-re-dot))) - "directory file"))) - -(defun dired-mark-executables (unflag-p) - "Mark all executable files. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-exe) "executable file"))) - -;; dired-x.el has a dired-mark-sexp interactive command: mark -;; files for which PREDICATE returns non-nil. - -(defun dired-flag-auto-save-files (&optional unflag-p) - "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unflag those files instead." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (looking-at dired-re-dir)) - (let ((fn (dired-get-filename t t))) - (if fn (auto-save-file-name-p - (file-name-nondirectory fn))))) - "auto save file"))) - -(defun dired-flag-backup-files (&optional unflag-p) - "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unflag these files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (looking-at dired-re-dir)) - (let ((fn (dired-get-filename t t))) - (if fn (backup-file-name-p fn)))) - "backup file"))) - - -;;; Shell commands -;;#### install (move this function into simple.el) -(defun shell-quote (filename) ; actually belongs into simple.el - "Quote a file name for inferior shell (see variable shell-file-name)." - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really wierd shells. - (let ((result "") (start 0) end) - (while (string-match "[^---0-9a-zA-Z_./]" filename start) - (setq end (match-beginning 0) - result (concat result (substring filename start end) - "\\" (substring filename end (1+ end))) - start (1+ end))) - (concat result (substring filename start)))) - -(defun dired-read-shell-command (prompt arg files) -;; "Read a dired shell command prompting with PROMPT (using read-string). -;;ARG is the prefix arg and may be used to indicate in the prompt which -;; files are affected. -;;This is an extra function so that you can redefine it, e.g., to use gmhist." - (dired-mark-pop-up - nil 'shell files - (function read-string) (format prompt (dired-mark-prompt arg files)))) - -;; The in-background argument is only needed in Emacs 18 where -;; shell-command doesn't understand an appended ampersand `&'. -(defun dired-do-shell-command (&optional arg in-background) - "Run a shell command on the marked files. -If there is output, it goes to a separate buffer. -The list of marked files is appended to the command string unless asterisks - `*' indicate the place(s) where the list should go. -If no files are marked or a specific numeric prefix arg is given, uses - next ARG files. As always, a raw arg (\\[universal-argument]) means the current file. - The prompt mentions the file(s) or the marker, as appropriate. -With a zero argument, run command on each marked file separately: `cmd * - foo' results in `cmd F1 foo; ...; cmd Fn foo'. -No automatic redisplay is attempted, as the file names may have - changed. Type \\[dired-do-redisplay] to redisplay the marked files. -The shell command has the top level directory as working directory, so - output files usually are created there instead of in a subdir." -;;Functions dired-run-shell-command and dired-shell-stuff-it do the -;;actual work and can be redefined for customization. - (interactive "P") - (let* ((on-each (equal arg 0)) - (prompt (concat (if in-background "& on " "! on ") - (if on-each "each " "") - "%s: ")) - (file-list (dired-mark-get-files t (if on-each nil arg))) - ;; Want to give feedback whether this file or marked files are used: - (command (dired-read-shell-command - prompt (if on-each nil arg) file-list)) - (result - (dired-shell-stuff-it command file-list on-each arg))) - ;; execute the shell command - (dired-run-shell-command result in-background))) - -;; Might use {,} for bash or csh: -(defvar dired-mark-prefix "" - "Prepended to marked files in dired shell commands.") -(defvar dired-mark-postfix "" - "Appended to marked files in dired shell commands.") -(defvar dired-mark-separator " " - "Separates marked files in dired shell commands.") - -(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) -;; "Make up a shell command line from COMMAND and FILE-LIST. -;; If ON-EACH is t, COMMAND should be applied to each file, else -;; simply concat all files and apply COMMAND to this. -;; FILE-LIST's elements will be quoted for the shell." -;; Might be redefined for smarter things and could then use RAW-ARG -;; (coming from interactive P and currently ignored) to decide what to do. -;; Smart would be a way to access basename or extension of file names. -;; See dired-trns.el for an approach to this. - ;; Bug: There is no way to quote a * - ;; On the other hand, you can never accidentally get a * into your cmd. - (let ((stuff-it - (if (string-match "\\*" command) - (function (lambda (x) - (dired-replace-in-string "\\*" x command))) - (function (lambda (x) (concat command " " x)))))) - (if on-each - (mapconcat stuff-it (mapcar (function shell-quote) file-list) ";") - (let ((fns (mapconcat (function shell-quote) - file-list dired-mark-separator))) - (if (> (length file-list) 1) - (setq fns (concat dired-mark-prefix fns dired-mark-postfix))) - (funcall stuff-it fns))))) - -;; This is an extra function so that it can be redefined by ange-ftp. -(defun dired-run-shell-command (command &optional in-background) - (if (and in-background (not (string-match "&[ \t]*$" command))) - (setq command (concat command " &"))) - (shell-command command)) - -(defun dired-do-print (&optional arg) - "Print the marked (or next ARG) files. -Uses the shell command coming from variables `lpr-command' and -`lpr-switches' as default." - (interactive "P") - (or (listp lpr-switches) - (error "lpr-switches must be a *list* of strings")) - (let* ((file-list (dired-mark-get-files t arg)) - (switches (mapconcat (function identity) lpr-switches " ")) - (command (dired-mark-read-string - "Print %s with: " - (concat lpr-command " " switches) - 'print arg file-list))) - (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))) - - -;;; 10K -;;;###begin dired-cp.el -;;; Copy, move/rename, making hard and symbolic links - -(defvar dired-backup-if-overwrite nil - "*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -(defun dired-handle-overwrite (to) - ;; Save old version of a to be overwritten file TO. - ;; `overwrite-confirmed' and `overwrite-backup-query' are fluid vars - ;; from dired-create-files. - (if (and dired-backup-if-overwrite - overwrite-confirmed - (or (eq 'always dired-backup-if-overwrite) - (dired-query 'overwrite-backup-query - (format "Make backup for existing file `%s'? " to)))) - (let ((backup (car (find-backup-file-name to)))) - (rename-file to backup 0) ; confirm overwrite of old backup - (dired-relist-entry backup)))) - -(defun dired-copy-file (from to ok-flag) - (dired-handle-overwrite to) - (copy-file from to ok-flag dired-copy-preserve-time)) - -(defun dired-rename-file (from to ok-flag) - (dired-handle-overwrite to) - (rename-file from to ok-flag) ; error is caught in -create-files - ;; Silently rename the visited file of any buffer visiting this file. - (and (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag)))) - (dired-remove-file from) - ;; See if it's an inserted subdir, and rename that, too. - (dired-rename-subdir from to)) - -(defun dired-rename-subdir (from-dir to-dir) - (setq from-dir (file-name-as-directory from-dir) - to-dir (file-name-as-directory to-dir)) - (dired-fun-in-all-buffers from-dir - (function dired-rename-subdir-1) from-dir to-dir) - ;; Update visited file name of all affected buffers - (let ((blist (buffer-list))) - (while blist - (save-excursion - (set-buffer (car blist)) - (if (and buffer-file-name - (dired-in-this-tree buffer-file-name from-dir)) - (let ((modflag (buffer-modified-p)) - (to-file (dired-replace-in-string - (concat "^" (regexp-quote from-dir)) - to-dir - buffer-file-name))) - (set-visited-file-name to-file) - (set-buffer-modified-p modflag)))) - (setq blist (cdr blist))))) - -(defun dired-rename-subdir-1 (dir to) - ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or - ;; one of its subdirectories is expanded in this buffer. - (let ((alist dired-subdir-alist) - (elt nil)) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (if (dired-in-this-tree (car elt) dir) - ;; ELT's subdir is affected by the rename - (dired-rename-subdir-2 elt dir to))) - (if (equal dir default-directory) - ;; if top level directory was renamed, lots of things have to be - ;; updated: - (progn - (dired-unadvertise dir) ; we no longer dired DIR... - (setq default-directory to - dired-directory (expand-file-name;; this is correct - ;; with and without wildcards - (file-name-nondirectory dired-directory) - to)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - (or (get-buffer new-name) - (rename-buffer new-name))) - ;; ... we dired TO now: - (dired-advertise))))) - -(defun dired-rename-subdir-2 (elt dir to) - ;; Update the headerline and dired-subdir-alist element of directory - ;; described by alist-element ELT to reflect the moving of DIR to TO. - ;; Thus, ELT describes either DIR itself or a subdir of DIR. - - ;; Bug: If TO is not longer part of the same dired tree as DIR was, - ;; updating the headerline is actually not the right thing---it - ;; should be removed in that case and a completely new entry be - ;; added for TO. Actually, removing and adding anew would always be - ;; the right (but slow) way of doing it. - - ;; The consequences are pretty harmless though (no updates since - ;; dired-buffers-for-dir will not suspect it to be in this dired - ;; buffer). - - (save-excursion - (let ((regexp (regexp-quote (directory-file-name dir))) - (newtext (directory-file-name to)) - buffer-read-only) - (goto-char (dired-get-subdir-min elt)) - ;; Update subdir headerline in buffer - (if (not (looking-at dired-subdir-regexp)) - (error "%s not found where expected - dired-subdir-alist broken?" - dir) - (goto-char (match-beginning 1)) - (if (re-search-forward regexp (match-end 1) t) - (replace-match newtext t t) - (error "Expected to find `%s' in headerline of %s" dir (car elt)))) - ;; Update buffer-local dired-subdir-alist - (setcar elt - (dired-normalize-subdir - (dired-replace-in-string regexp newtext (car elt))))))) - -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If it does not match, nil is returned instead of the new string. -Optional arg LITERAL means to take NEWTEXT literally. -Optional arg GLOBAL means to replace all matches." - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - -;; The basic function for half a dozen variations on cp/mv/ln/ln -s. -(defun dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char) - -;; Create a new file for each from a list of existing files. The user -;; is queried, dired buffers are updated, and at the end a success or -;; failure message is displayed - -;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists - -;; It is called for each file and must create newfile, the entry of -;; which will be added. The user will be queried if the file already -;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a -;; rename), it is FILE-CREATOR's responsibility to update dired -;; buffers. FILE-CREATOR must abort by signalling a file-error if it -;; could not create newfile. The error is caught and logged. - -;; OPERATION (a capitalized string, e.g. `Copy') describes the -;; operation performed. It is used for error logging. - -;; FN-LIST is the list of files to copy (full absolute pathnames). - -;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to -;; skip. If it skips files for other reasons than a direct user -;; query, it is supposed to tell why (using dired-log). - -;; Optional MARKER-CHAR is a character with which to mark every -;; newfile's entry, or t to use the current marker character if the -;; oldfile was marked. - - (let (failures skipped (success-count 0) (total (length fn-list))) - (let (to overwrite-query - overwrite-backup-query) ; for dired-handle-overwrite - (mapcar - (function - (lambda (from) - (setq to (funcall name-constructor from)) - (if (equal to from) - (progn - (setq to nil) - (dired-log "Cannot %s to same file: %s\n" - (downcase operation) from))) - (if (not to) - (setq skipped (cons (dired-make-relative from) skipped)) - (let* ((overwrite (file-exists-p to)) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to)))) - ;; must determine if FROM is marked before file-creator - ;; gets a chance to delete it (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) ; slow - (t nil)))) - (condition-case err - (progn - (funcall file-creator from to overwrite-confirmed) - (if overwrite - ;; If we get here, file-creator hasn't been aborted - ;; and the old entry (if any) has to be deleted - ;; before adding the new entry. - (dired-remove-file to)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (dired-add-file to actual-marker-char)) - (file-error ; FILE-CREATOR aborted - (progn - (setq failures (cons (dired-make-relative from) failures)) - (dired-log "%s `%s' to `%s' failed:\n%s\n" - operation from to err)))))))) - fn-list)) - (cond - (failures - (dired-log-summary - (message "%s failed for %d of %d file%s %s" - operation (length failures) total - (dired-plural-s total) failures))) - (skipped - (dired-log-summary - (message "%s: %d of %d file%s skipped %s" - operation (length skipped) total - (dired-plural-s total) skipped))) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count))))) - (dired-move-to-filename)) - -(defun dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char op1 - how-to) - ;; Create a new file for each marked file. - ;; Prompts user for target, which is a directory in which to create - ;; the new files. Target may be a plain file if only one marked - ;; file exists. - ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' - ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; Optional arg OP1 is an alternate form for OPERATION if there is - ;; only one file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - ;; Optional arg HOW-TO determines how to treat target: - ;; If HOW-TO is not given (or nil), and target is a directory, the - ;; file(s) are created inside the target directory. If target - ;; is not a directory, there must be exactly one marked file, - ;; else error. - ;; If HOW-TO is t, then target is not modified. There must be - ;; exactly one marked file, else error. - ;; Else HOW-TO is assumed to be a function of one argument, target, - ;; that looks at target and returns a value for the into-dir - ;; variable. The function dired-into-dir-with-symlinks is provided - ;; for the case (common when creating symlinks) that symbolic - ;; links to directories are not to be considered as directories - ;; (as file-directory-p would if HOW-TO had been nil). - (or op1 (setq op1 operation)) - (let* ((fn-list (dired-mark-get-files nil arg)) - (fn-count (length fn-list)) - (target (expand-file-name - (dired-mark-read-file-name - (concat (if (= 1 fn-count) op1 operation) " %s to: ") - (dired-dwim-target-directory) - op-symbol arg (mapcar (function dired-make-relative) fn-list)))) - (into-dir (cond ((null how-to) (file-directory-p target)) - ((eq how-to t) nil) - (t (funcall how-to target))))) - (if (and (> fn-count 1) - (not into-dir)) - (error "Marked %s: target must be a directory: %s" operation target)) - ;; rename-file bombs when moving directories unless we do this: - (or into-dir (setq target (directory-file-name target))) - (dired-create-files - file-creator operation fn-list - (if into-dir ; target is a directory - ;; This function uses fluid vars into-dir and target when called - ;; inside dired-create-files: - (function (lambda (from) - (expand-file-name (file-name-nondirectory from) target))) - (function (lambda (from) target))) - marker-char))) - -(defun dired-dwim-target-directory () - ;; Try to guess which target directory the user may want. - ;; If there is a dired buffer displayed in the next window, use - ;; its current subdir, else use current subdir of this dired buffer. - (let ((this-dir (and (eq major-mode 'dired-mode) - (dired-current-directory)))) - ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode - (if dired-dwim-target - (let* ((other-buf (window-buffer (next-window))) - (other-dir (save-excursion - (set-buffer other-buf) - (and (eq major-mode 'dired-mode) - (dired-current-directory))))) - (or other-dir this-dir)) - this-dir))) - -(defun dired-into-dir-with-symlinks (target) - (and (file-directory-p target) - (not (file-symlink-p target)))) -;; This may not always be what you want, especially if target is your -;; home directory and it happens to be a symbolic link, as is often the -;; case with NFS and automounters. Or if you want to make symlinks -;; into directories that themselves are only symlinks, also quite -;; common. - -;; So we don't use this function as value for HOW-TO in -;; dired-do-symlink, which has the minor disadvantage of -;; making links *into* a symlinked-dir, when you really wanted to -;; *overwrite* that symlink. In that (rare, I guess) case, you'll -;; just have to remove that symlink by hand before making your marked -;; symlinks. - -(defun dired-do-copy (&optional arg) - "Copy all marked (or next ARG) files, or copy the current file. -Thus, a zero prefix argument copies nothing. But it toggles the -variable `dired-copy-preserve-time' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'copy (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg dired-keep-marker-copy) - (setq dired-copy-preserve-time (not dired-copy-preserve-time)) - (if dired-copy-preserve-time - (message "Copy will preserve time.") - (message "Copied files will get current date.")))) - -(defun dired-do-symlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file." - (interactive "P") - (dired-do-create-files 'symlink (function make-symbolic-link) - "SymLink" arg dired-keep-marker-symlink)) - -(defun dired-do-hardlink (&optional arg) - "Hard-link all marked (or next ARG) files into a directory, -or make a hard link to the current file." - (interactive "P") - (dired-do-create-files 'hardlink (function add-name-to-file) - "HardLink" arg dired-keep-marker-hardlink)) - -(defun dired-do-move (&optional arg) - "Move all marked (or next ARG) files into a directory, -or rename the current file. -A zero ARG moves no files but toggles `dired-dwim-target' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'move (function dired-rename-file) - "Move" arg dired-keep-marker-move "Rename") - (setq dired-dwim-target (not dired-dwim-target)) - (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) - -;;;###end dired-cp.el - -;;; 5K -;;;###begin dired-re.el -(defun dired-do-create-files-regexp - (file-creator operation arg regexp newname &optional whole-path marker-char) - ;; Create a new file for each marked file using regexps. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; Matches each marked file against REGEXP and constructs the new - ;; filename from NEWNAME (like in function replace-match). - ;; Optional arg WHOLE-PATH means match/replace the whole pathname - ;; instead of only the non-directory part of the file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - (let* ((fn-list (dired-mark-get-files nil arg)) - (fn-count (length fn-list)) - (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) - (regexp-name-constructor - ;; Function to construct new filename using REGEXP and NEWNAME: - (if whole-path ; easy (but rare) case - (function - (lambda (from) - (let ((to (dired-string-replace-match regexp from newname)) - ;; must bind help-form directly around call to - ;; dired-query - (help-form rename-regexp-help-form)) - (if to - (and (dired-query 'rename-regexp-query - operation-prompt - from - to) - to) - (dired-log "%s: %s did not match regexp %s\n" - operation from regexp))))) - ;; not whole-path, replace non-directory part only - (function - (lambda (from) - (let* ((new (dired-string-replace-match - regexp (file-name-nondirectory from) newname)) - (to (and new ; nil means there was no match - (expand-file-name new - (file-name-directory from)))) - (help-form rename-regexp-help-form)) - (if to - (and (dired-query 'rename-regexp-query - operation-prompt - (dired-make-relative from) - (dired-make-relative to)) - to) - (dired-log "%s: %s did not match regexp %s\n" - operation (file-name-nondirectory from) regexp))))))) - rename-regexp-query) - (dired-create-files - file-creator operation fn-list regexp-name-constructor marker-char))) - -(defun dired-mark-read-regexp (operation) - ;; Prompt user about performing OPERATION. - ;; Read and return list of: regexp newname arg whole-path. - (let* ((whole-path - (equal 0 (prefix-numeric-value current-prefix-arg))) - (arg - (if whole-path nil current-prefix-arg)) - (regexp - (dired-read-regexp - (concat (if whole-path "Path " "") operation " from (regexp): ") - dired-flagging-regexp)) - (newname - (read-string - (concat (if whole-path "Path " "") operation " " regexp " to: ")))) - (list regexp newname arg whole-path))) - -(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) - "Rename marked files containing REGEXP to NEWNAME. -As each match is found, the user must type a character saying - what to do with it. For directions, type \\[help-command] at that time. -NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. -REGEXP defaults to the last regexp used. -With a zero prefix arg, renaming by regexp affects the complete - pathname - usually only the non-directory part of file names is used - and changed." - (interactive (dired-mark-read-regexp "Rename")) - (dired-do-create-files-regexp - (function dired-rename-file) - "Rename" arg regexp newname whole-path dired-keep-marker-move)) - -(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) - "Copy all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "Copy")) - (dired-do-create-files-regexp - (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg regexp newname whole-path dired-keep-marker-copy)) - -(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) - "Hardlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "HardLink")) - (dired-do-create-files-regexp - (function add-name-to-file) - "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) - -(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) - "Symlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "SymLink")) - (dired-do-create-files-regexp - (function make-symbolic-link) - "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) - -(defun dired-create-files-non-directory - (file-creator basename-constructor operation arg) - ;; Perform FILE-CREATOR on the non-directory part of marked files - ;; using function BASENAME-CONSTRUCTOR, with query for each file. - ;; OPERATION like in dired-create-files, ARG like in dired-mark-get-files. - (let (rename-non-directory-query) - (dired-create-files - file-creator - operation - (dired-mark-get-files nil arg) - (function - (lambda (from) - (let ((to (concat (file-name-directory from) - (funcall basename-constructor - (file-name-nondirectory from))))) - (and (let ((help-form (format "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) - (dired-query 'rename-non-directory-query - (concat operation " `%s' to `%s'") - (dired-make-relative from) - (dired-make-relative to))) - to)))) - dired-keep-marker-move))) - -(defun dired-rename-non-directory (basename-constructor operation arg) - (dired-create-files-non-directory - (function dired-rename-file) - basename-constructor operation arg)) - -(defun dired-upcase (&optional arg) - "Rename all marked (or next ARG) files to upper case." - (interactive "P") - (dired-rename-non-directory (function upcase) "Rename upcase" arg)) - -(defun dired-downcase (&optional arg) - "Rename all marked (or next ARG) files to lower case." - (interactive "P") - (dired-rename-non-directory (function downcase) "Rename downcase" arg)) - -;;;###end dired-re.el - - -;; Tree Dired - -;;; utility functions - -(defun dired-in-this-tree (file dir) - ;;"Is FILE part of the directory tree starting at DIR?" - (let (case-fold-search) - (string-match (concat "^" (regexp-quote dir)) file))) - -(defun dired-make-absolute (file &optional dir) - ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname." - ;; We can't always use expand-file-name as this would get rid of `.' - ;; or expand in / instead default-directory if DIR=="". - ;; This should be good enough for ange-ftp, but might easily be - ;; redefined (for VMS?). - ;; It should be reasonably fast, though, as it is called in - ;; dired-get-filename. - (concat (or dir default-directory) file)) - -(defun dired-make-relative (file &optional dir no-error) - ;;"Convert FILE (an absolute pathname) to a pathname relative to DIR. - ;; Else error (unless NO-ERROR is non-nil, then FILE is returned unchanged) - ;;DIR defaults to default-directory." - ;; DIR must be file-name-as-directory, as with all directory args in - ;; elisp code. - (or dir (setq dir default-directory)) - (if (string-match (concat "^" (regexp-quote dir)) file) - (substring file (match-end 0)) - (if no-error - file - (error "%s: not in directory tree growing at %s" file dir)))) - -(defun dired-normalize-subdir (dir) - ;; Prepend default-directory to DIR if relative path name. - ;; dired-get-filename must be able to make a valid filename from a - ;; file and its directory DIR. - (file-name-as-directory - (if (file-name-absolute-p dir) - dir - (expand-file-name dir default-directory)))) - -(defun dired-between-files () - ;; Point must be at beginning of line - ;; Should be equivalent to (save-excursion (not (dired-move-to-filename))) - ;; but is about 1.5..2.0 times as fast. (Actually that's not worth it) - (or (looking-at "^$\\|^. *$\\|^. total\\|^. wildcard") - (looking-at dired-subdir-regexp))) - -(defun dired-get-subdir () - ;;"Return the subdir name on this line, or nil if not on a headerline." - ;; Look up in the alist whether this is a headerline. - (save-excursion - (let ((cur-dir (dired-current-directory))) - (beginning-of-line) ; alist stores b-o-l positions - (and (zerop (- (point) - (dired-get-subdir-min (assoc cur-dir - dired-subdir-alist)))) - cur-dir)))) - -;(defun dired-get-subdir-min (elt) -; (cdr elt)) -;; can't use macro, must be redefinable for other alist format in dired-nstd. -(fset 'dired-get-subdir-min 'cdr) - -(defun dired-get-subdir-max (elt) - (save-excursion - (goto-char (dired-get-subdir-min elt)) - (dired-subdir-max))) - -(defun dired-clear-alist () - (while dired-subdir-alist - (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (set (make-local-variable 'dired-subdir-alist) - (list (cons default-directory (point-min-marker))))) - -(defun dired-build-subdir-alist () - "Build `dired-subdir-alist' by parsing the buffer and return it's new value." - (interactive) - (dired-clear-alist) - (save-excursion - (let ((count 0)) - (goto-char (point-min)) - (setq dired-subdir-alist nil) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (dired-alist-add-1 (buffer-substring (match-beginning 1) - (match-end 1)) - ;; Put subdir boundary between lines: - (save-excursion - (goto-char (match-beginning 0)) - (beginning-of-line) - (point-marker))) - (message "%d" count)) - (message "%d director%s." count (if (= 1 count) "y" "ies")) - ;; We don't need to sort it because it is in buffer order per - ;; constructionem. Return new alist: - dired-subdir-alist))) - -(defun dired-alist-add (dir new-marker) - ;; Add new DIR at NEW-MARKER. Sort alist. - (dired-alist-add-1 dir new-marker) - (dired-alist-sort)) - -(defun dired-alist-add-1 (dir new-marker) - ;; Add new DIR at NEW-MARKER. Don't sort. - (setq dired-subdir-alist - (cons (cons (dired-normalize-subdir dir) new-marker) - dired-subdir-alist))) - -(defun dired-alist-sort () - ;; Keep the alist sorted on buffer position. - (setq dired-subdir-alist - (sort dired-subdir-alist - (function (lambda (elt1 elt2) - (> (dired-get-subdir-min elt1) - (dired-get-subdir-min elt2))))))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist - (setq dired-subdir-alist - (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) - -(defun dired-goto-next-nontrivial-file () - ;; Position point on first nontrivial file after point. - (dired-goto-next-file);; so there is a file to compare with - (if (stringp dired-trivial-filenames) - (while (and (not (eobp)) - (string-match dired-trivial-filenames - (file-name-nondirectory - (or (dired-get-filename nil t) "")))) - (forward-line 1) - (dired-move-to-filename)))) - -(defun dired-goto-next-file () - (let ((max (1- (dired-subdir-max)))) - (while (and (not (dired-move-to-filename)) (< (point) max)) - (forward-line 1)))) - -(defun dired-goto-subdir (dir) - "Goto end of header line of DIR in this dired buffer. -Return value of point on success, otherwise return nil. -The next char is either \\n, or \\r if DIR is hidden." - (interactive - (prog1 ; let push-mark display its message - (list (expand-file-name - (completing-read "Goto in situ directory: " ; prompt - dired-subdir-alist ; table - nil ; predicate - t ; require-match - (dired-current-directory)))) - (push-mark))) - (setq dir (file-name-as-directory dir)) - (let ((elt (assoc dir dired-subdir-alist))) - (and elt - (goto-char (dired-get-subdir-min elt)) - ;; dired-subdir-hidden-p and dired-add-entry depend on point being - ;; at either \r or \n after this function succeeds. - (progn (skip-chars-forward "^\r\n") - (point))))) - -(defun dired-goto-file (file) - "Goto file line of FILE in this dired buffer." - ;; Return value of point on success, else nil. - ;; FILE must be an absolute pathname. - ;; Loses if FILE contains control chars like "\007" for which ls - ;; either inserts "?" or "\\007" into the buffer, so we won't find - ;; it in the buffer. - (interactive - (prog1 ; let push-mark display its message - (list (expand-file-name - (read-file-name "Goto file: " - (dired-current-directory)))) - (push-mark))) - (setq file (directory-file-name file)) ; does no harm if no directory - (let (found case-fold-search) - (save-excursion - (if (dired-goto-subdir (or (file-name-directory file) - (error "Need absolute pathname for %s" file))) - (let ((base (file-name-nondirectory file)) - (boundary (dired-subdir-max))) - (while (and (not found) - ;; filenames are preceded by SPC, this makes - ;; the search faster (e.g. for the filename "-"!). - (search-forward (concat " " base) boundary 'move)) - ;; Match could have BASE just as initial substring - ;; or in permission bits or date or - ;; not be a proper filename at all: - (if (equal base (dired-get-filename 'no-dir t)) - ;; Must move to filename since an (actually - ;; correct) match could have been elsewhere on the - ;; ;; line (e.g. "-" would match somewhere in the - ;; permission bits). - (setq found (dired-move-to-filename))))))) - (and found - ;; return value of point (i.e., FOUND): - (goto-char found)))) - -(defun dired-initial-position (dirname) - ;; Where point should go in a new listing of DIRNAME. - ;; Point assumed at beginning of new subdir line. - ;; You may redefine this function as you wish, e.g. like in dired-x.el. - (end-of-line) - (if dired-trivial-filenames (dired-goto-next-nontrivial-file))) - -;;; moving by subdirectories - -(defun dired-subdir-index (dir) - ;; Return an index into alist for use with nth - ;; for the sake of subdir moving commands. - (let (found (index 0) (alist dired-subdir-alist)) - (while alist - (if (string= dir (car (car alist))) - (setq alist nil found t) - (setq alist (cdr alist) index (1+ index)))) - (if found index nil))) - -(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) - "Go to next subdirectory, regardless of level." - ;; Use 0 arg to go to this directory's header line. - ;; NO-SKIP prevents moving to end of header line, returning whatever - ;; position was found in dired-subdir-alist. - (interactive "_p") - (let ((this-dir (dired-current-directory)) - pos index) - ;; nth with negative arg does not return nil but the first element - (setq index (- (dired-subdir-index this-dir) arg)) - (setq pos (if (>= index 0) - (dired-get-subdir-min (nth index dired-subdir-alist)))) - (if pos - (progn - (goto-char pos) - (or no-skip (skip-chars-forward "^\n\r")) - (point)) - (if no-error-if-not-found - nil ; return nil if not found - (error "%s directory" (if (> arg 0) "Last" "First")))))) - -(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) - "Go to previous subdirectory, regardless of level. -When called interactively and not on a subdir line, go to this subdir's line." - ;;(interactive "_p") - (interactive - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - ;; if on subdir start already, don't stay there! - (if (dired-get-subdir) 1 0)))) - (dired-next-subdir (- arg) no-error-if-not-found no-skip)) - -(defun dired-tree-up (arg) - "Go up ARG levels in the dired tree." - (interactive "_p") - (let ((dir (dired-current-directory))) - (while (>= arg 1) - (setq arg (1- arg) - dir (file-name-directory (directory-file-name dir)))) - ;;(setq dir (expand-file-name dir)) - (or (dired-goto-subdir dir) - (error "Cannot go up to %s - not in this tree." dir)))) - -(defun dired-tree-down () - "Go down in the dired tree." - (interactive "_") - (let ((dir (dired-current-directory)) ; has slash - pos case-fold-search) ; filenames are case sensitive - (let ((rest (reverse dired-subdir-alist)) elt) - (while rest - (setq elt (car rest) - rest (cdr rest)) - (if (dired-in-this-tree (directory-file-name (car elt)) dir) - (setq rest nil - pos (dired-goto-subdir (car elt)))))) - (if pos - (goto-char pos) - (error "At the bottom")))) - -;;; hiding - -(defun dired-subdir-hidden-p (dir) - (and selective-display - (save-excursion - (dired-goto-subdir dir) - (looking-at "\r")))) - -(defun dired-unhide-subdir () - (let (buffer-read-only) - (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n))) - -(defun dired-hide-check () - (or selective-display - (error "selective-display must be t for subdir hiding to work!"))) - -(defun dired-hide-subdir (arg) - "Hide or unhide the current subdirectory and move to next directory. -Optional prefix arg is a repeat factor. -Use \\[dired-hide-all] to (un)hide all directories." - (interactive "p") - (dired-hide-check) - (while (>= (setq arg (1- arg)) 0) - (let* ((cur-dir (dired-current-directory)) - (hidden-p (dired-subdir-hidden-p cur-dir)) - (elt (assoc cur-dir dired-subdir-alist)) - (end-pos (1- (dired-get-subdir-max elt))) - buffer-read-only) - ;; keep header line visible, hide rest - (goto-char (dired-get-subdir-min elt)) - (skip-chars-forward "^\n\r") - (if hidden-p - (subst-char-in-region (point) end-pos ?\r ?\n) - (subst-char-in-region (point) end-pos ?\n ?\r))) - (dired-next-subdir 1 t))) - -(defun dired-hide-all (arg) - "Hide all subdirectories, leaving only their header lines. -If there is already something hidden, make everything visible again. -Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." - (interactive "P") - (dired-hide-check) - (let (buffer-read-only) - (if (save-excursion - (goto-char (point-min)) - (search-forward "\r" nil t)) - ;; unhide - bombs on \r in filenames - (subst-char-in-region (point-min) (point-max) ?\r ?\n) - ;; hide - (let ((pos (point-max)) ; pos of end of last directory - (alist dired-subdir-alist)) - (while alist ; while there are dirs before pos - (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir - (save-excursion - (goto-char pos) ; current dir - ;; we're somewhere on current dir's line - (forward-line -1) - (point)) - ?\n ?\r) - (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir - (setq alist (cdr alist))))))) - - -;; This function is the heart of tree dired. -;; It is called for each retrieved filename. -;; It could stand to be faster, though it's mostly function call -;; overhead. Avoiding to funcall seems to save about 10% in -;; dired-get-filename. Make it a defsubst? -(defun dired-current-directory (&optional localp) - "Return the name of the subdirectory to which this line belongs. -This returns a string with trailing slash, like `default-directory'. -Optional argument means return a file name relative to `default-directory'." - (let ((here (point)) - (alist (or dired-subdir-alist - ;; probably because called in a non-dired buffer - (error "No subdir-alist in %s" (current-buffer)))) - elt dir) - (while alist - (setq elt (car alist) - dir (car elt) - ;; use `<=' (not `<') as subdir line is part of subdir - alist (if (<= (dired-get-subdir-min elt) here) - nil ; found - (cdr alist)))) - (if localp - (dired-make-relative dir default-directory) - dir))) - -;; Subdirs start at the beginning of their header lines and end just -;; before the beginning of the next header line (or end of buffer). - -(defun dired-subdir-min () - (save-excursion - (if (not (dired-prev-subdir 0 t t)) - (error "Not in a subdir!") - (point)))) - -(defun dired-subdir-max () - (save-excursion - (if (not (dired-next-subdir 1 t t)) - (point-max) - (point)))) - -(defun dired-kill-line-or-subdir (&optional arg) - "Kill this line (but not this file). -Optional prefix argument is a repeat factor. -If file is displayed as in situ subdir, kill that as well. -If on a subdir headerline, kill whole subdir." - (interactive "p") - (if (dired-get-subdir) - (dired-kill-subdir) - (dired-kill-line arg))) - -(defun dired-kill-line (&optional arg) - (interactive "P") - (setq arg (prefix-numeric-value arg)) - (let (buffer-read-only file) - (while (/= 0 arg) - (setq file (dired-get-filename nil t)) - (if (not file) - (error "Can only kill file lines.") - (save-excursion (and file - (dired-goto-subdir file) - (dired-kill-subdir))) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) - (if (> arg 0) - (setq arg (1- arg)) - (setq arg (1+ arg)) - (forward-line -1)))) - (dired-move-to-filename))) - -(defun dired-kill-subdir (&optional remember-marks) - "Remove all lines of current subdirectory. -Lower levels are unaffected." - ;; With optional REMEMBER-MARKS, return a mark-alist. - (interactive) - (let ((beg (dired-subdir-min)) - (end (dired-subdir-max)) - buffer-read-only cur-dir) - (setq cur-dir (dired-current-directory)) - (if (equal cur-dir default-directory) - (error "Attempt to kill top level directory")) - (prog1 - (if remember-marks (dired-remember-marks beg end)) - (delete-region beg end) - (if (eobp) ; don't leave final blank line - (delete-char -1)) - (dired-unsubdir cur-dir)))) - -(defun dired-do-kill (&optional arg fmt) - "Kill all marked lines (not files). -With a prefix arg, kill all lines not marked or flagged." - ;; Returns count of killed lines. FMT="" suppresses message. - (interactive "P") - (save-excursion - (goto-char (point-min)) - (let (buffer-read-only (count 0)) - (if (not arg) ; kill marked lines - (let ((regexp (dired-marker-regexp))) - (while (and (not (eobp)) - (re-search-forward regexp nil t)) - (setq count (1+ count)) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))))) - ;; else kill unmarked lines - (while (not (eobp)) - (if (or (dired-between-files) - (not (looking-at "^ "))) - (forward-line 1) - (setq count (1+ count)) - (delete-region (point) (save-excursion - (forward-line 1) - (point)))))) - (or (equal "" fmt) - (message (or fmt "Killed %d line%s.") count (dired-plural-s count))) - count))) - -(defun dired-do-redisplay (&optional arg test-for-subdir) - "Redisplay all marked (or next ARG) files. - -If on a subdir line, redisplay that subdirectory. In that case, -a prefix arg lets you edit the ls switches used for the new listing." - ;; Moves point if the next ARG files are redisplayed. - (interactive "P\np") - (if (and test-for-subdir (dired-get-subdir)) - (dired-insert-subdir - (dired-get-subdir) - (if arg (read-string "Switches for listing: " dired-actual-switches))) - (message "Redisplaying...") - ;; message instead of making dired-mark-map show-progress is much faster - (dired-mark-map (let ((fname (dired-get-filename))) - (message "Redisplaying... %s" fname) - (dired-update-file-line fname)) - arg) - (dired-move-to-filename) - (message "Redisplaying...done"))) - -(defun dired-mark-files-in-region (start end) - (let (buffer-read-only) - (if (> start end) - (error "start > end")) - (goto-char start) ; assumed at beginning of line - (while (< (point) end) - ;; Skip subdir line and following garbage like the `total' line: - (while (and (< (point) end) (dired-between-files)) - (forward-line 1)) - (if (and (not (looking-at dired-re-dot)) - (dired-get-filename nil t)) - (progn - (delete-char 1) - (insert dired-marker-char))) - (forward-line 1)))) - -(defun dired-mark-subdir-files () - "Mark all files except `.' and `..'." - (interactive "P") - (let ((p-min (dired-subdir-min))) - (dired-mark-files-in-region p-min (dired-subdir-max)))) - -(defun dired-mark-subdir-or-file (arg) - "Mark the current (or next ARG) files. -If on a subdir headerline, mark all its files except `.' and `..'. - -Use \\[dired-unflag-all-files] to remove all marks -and \\[dired-unmark-subdir-or-file] on a subdir to remove the marks in -this subdir." - (interactive "P") - (if (dired-get-subdir) - (save-excursion (dired-mark-subdir-files)) - (dired-mark-file (prefix-numeric-value arg)))) - -(defun dired-unmark-subdir-or-file (arg) - "Unmark the current (or next ARG) files. -If looking at a subdir, unmark all its files except `.' and `..'." - (interactive "P") - (let ((dired-marker-char ?\040)) - (dired-mark-subdir-or-file arg))) - -;;; 5K -;;;###begin dired-ins.el - -(defun dired-maybe-insert-subdir (dirname &optional - switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, just move to it (type \\[dired-do-redisplay] to refresh), - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (let ((opoint (point))) - ;; We don't need a marker for opoint as the subdir is always - ;; inserted *after* opoint. - (setq dirname (file-name-as-directory dirname)) - (or (and (not switches) - (dired-goto-subdir dirname)) - (dired-insert-subdir dirname switches no-error-if-not-dir-p)) - ;; Push mark so that it's easy to find back. Do this after the - ;; insert message so that the user sees the `Mark set' message. - (push-mark opoint))) - -(defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (dired-insert-subdir-validate dirname switches) - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - switches-have-R mark-alist case-fold-search buffer-read-only) - ;; case-fold-search is nil now, so we can test for capital `R': - (if (setq switches-have-R (and switches (string-match "R" switches))) - ;; avoid duplicated subdirs - (setq mark-alist (dired-kill-tree dirname t))) - (if elt - ;; If subdir is already present, remove it and remember its marks - (setq mark-alist (nconc (dired-insert-subdir-del elt) mark-alist)) - (dired-insert-subdir-newpos dirname)) ; else compute new position - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-doinsert dirname switches)) - (if switches-have-R (dired-build-subdir-alist)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist)))) - -;; This is a separate function for dired-vms. -(defun dired-insert-subdir-validate (dirname &optional switches) - ;; Check that it is valid to insert DIRNAME with SWITCHES. - ;; Signal an error if invalid (e.g. user typed `i' on `..'). - (or (dired-in-this-tree dirname default-directory) - (error "%s: not in this directory tree" dirname)) - (if switches - (let (case-fold-search) - (mapcar - (function - (lambda (x) - (or (eq (null (string-match x switches)) - (null (string-match x dired-actual-switches))) - (error "Can't have dirs with and without -%s switches together" - x)))) - ;; all switches that make a difference to dired-get-filename: - '("F" "b"))))) - -(defun dired-kill-tree (dirname &optional remember-marks) - ;;"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. - ;; With optional arg REMEMBER-MARKS, return an alist of marked files." - (interactive "DKill tree below directory: ") - (let ((s-alist dired-subdir-alist) dir m-alist) - (while s-alist - (setq dir (car (car s-alist)) - s-alist (cdr s-alist)) - (if (and (not (string-equal dir dirname)) - (dired-in-this-tree dir dirname) - (dired-goto-subdir dir)) - (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) - m-alist)) - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist dired-subdir-alist) elt dir pos new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (or (eobp) - (forward-line -1)) - (insert "\n") - (point)) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element))) - (goto-char begin-marker) - ;; Are at beginning of subdir (and inside it!). Now determine its end: - (goto-char (dired-subdir-max)) - (or (eobp);; want a separating newline _between_ subdirs: - (forward-char -1)) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - -(defun dired-insert-subdir-doinsert (dirname switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - (let ((begin (point)) end) - (message "Reading directory %s..." dirname) - (let ((dired-actual-switches - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)))) - (if (equal dirname (car (car (reverse dired-subdir-alist)))) - ;; top level directory may contain wildcards: - (dired-readin-insert dired-directory) - (dired-ls dirname dired-actual-switches nil t))) - (message "Reading directory %s...done" dirname) - (setq end (point-marker)) - (dired-indent-rigidly begin end 2) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - ;; Need a marker for END as this inserts text. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -(defun dired-insert-subdir-doupdate (dirname elt beg-end) - ;; Point is at the correct subdir alist position for ELT, - ;; BEG-END is the subdir-region (as list of begin and end). - (if elt ; subdir was already present - ;; update its position (should actually be unchanged) - (set-marker (dired-get-subdir-min elt) (point-marker)) - (dired-alist-add dirname (point-marker))) - ;; The hook may depend on the subdir-alist containing the just - ;; inserted subdir, so run it after dired-alist-add: - (if dired-after-readin-hook - (save-excursion - (let ((begin (nth 0 beg-end)) - (end (nth 1 beg-end))) - (goto-char begin) - (save-restriction - (narrow-to-region begin end) - ;; hook may add or delete lines, but the subdir boundary - ;; marker floats - (run-hooks 'dired-after-readin-hook)))))) - -(defun dired-tree-lessp (dir1 dir2) - ;; Lexicographic order on pathname components, like `ls -lR': - ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, - ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, - ;; or DIR1 and DIR2 are in the same parentdir and their last - ;; components are string-lessp. - ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. - ;; string-lessp could arguably be replaced by file-newer-than-file-p - ;; if dired-actual-switches contained `t'. - (setq dir1 (file-name-as-directory dir1) - dir2 (file-name-as-directory dir2)) - (let ((components-1 (dired-split "/" dir1)) - (components-2 (dired-split "/" dir2))) - (while (and components-1 - components-2 - (equal (car components-1) (car components-2))) - (setq components-1 (cdr components-1) - components-2 (cdr components-2))) - (let ((c1 (car components-1)) - (c2 (car components-2))) - - (cond ((and c1 c2) - (string-lessp c1 c2)) - ((and (null c1) (null c2)) - nil) ; they are equal, not lessp - ((null c1) ; c2 is a subdir of c1: c1c2 - nil) - (t (error "This can't happen")))))) - -;; There should be a builtin split function - inverse to mapconcat. -(defun dired-split (pat str &optional limit) - "Splitting on regexp PAT, turn string STR into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list. -Thus, if SEP is a regexp that only matches itself, - - (mapconcat 'identity (dired-split SEP STRING) SEP) - -is always equal to STRING." - (let* ((start (string-match pat str)) - (result (list (substring str 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pat str end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring str end start) result) - end (match-end 0) - start end) - )) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring str end) result))) - (nreverse result))) - -(defun dired-indent-rigidly (start end arg) - ;; like indent-rigidly but has more efficient behavior w.r.t. the - ;; after-change-functions (i.e., font-lock-mode.) - (save-excursion - (let ((after-change-functions nil) - (after-change-function nil)) - (goto-char end) - (indent-rigidly start end arg)) - ;; deletion - (run-hook-with-args 'after-change-functions start start (- end start)) - (run-hook-with-args 'after-change-function start start (- end start)) - ;; insertion - (run-hook-with-args 'after-change-functions start (point) 0) - (run-hook-with-args 'after-change-function start (point) 0) - )) - -(if (string-lessp emacs-version "19") - (fset 'dired-indent-rigidly (symbol-function 'indent-rigidly))) - -;;;###end dired-ins.el - - -;;; Sorting - -;; Most ls can only sort by name or by date (with -t), nothing else. -;; GNU ls sorts on size with -S, on extension with -X, and unsorted with -U. -;; So anything that does not contain these is sort "by name". - -(defvar dired-ls-sorting-switches "SXU" - "String of ls switches (single letters) except `t' that influence sorting.") - -(defvar dired-sort-by-date-regexp - (concat "^-[^" dired-ls-sorting-switches - "]*t[^" dired-ls-sorting-switches "]*$") - "Regexp recognized by dired to set `by date' mode.") - -(defvar dired-sort-by-name-regexp - (concat "^-[^t" dired-ls-sorting-switches "]+$") - "Regexp recognized by dired to set `by name' mode.") - -(defvar dired-sort-mode nil - "Whether Dired sorts by name, date etc. (buffer-local).") -;; This is nil outside dired buffers so it can be used in the modeline - -(defun dired-sort-set-modeline () - ;; Set modeline display according to dired-actual-switches. - ;; Modeline display of "by name" or "by date" guarantees the user a - ;; match with the corresponding regexps. Non-matching switches are - ;; shown literally. - (setq dired-sort-mode - (let (case-fold-search) - (cond ((string-match dired-sort-by-name-regexp dired-actual-switches) - " by name") - ((string-match dired-sort-by-date-regexp dired-actual-switches) - " by date") - (t - (concat " " dired-actual-switches))))) - ;; update mode line: - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-sort-toggle-or-edit (&optional arg) - "Toggle between sort by date/name and refresh the dired buffer. -With a prefix argument you can edit the current listing switches instead." - (interactive "P") - (if arg - (dired-sort-other - (read-string "ls switches (must contain -l): " dired-actual-switches)) - (dired-sort-toggle))) - -(defun dired-sort-toggle () - ;; Toggle between sort by date/name. Reverts the buffer. - (setq dired-actual-switches - (let (case-fold-search) - (concat - "-l" - (dired-replace-in-string (concat "[---lt" - dired-ls-sorting-switches "]") - "" - dired-actual-switches) - (if (string-match (concat "[t" dired-ls-sorting-switches "]") - dired-actual-switches) - "" - "t")))) - (dired-sort-set-modeline) - (revert-buffer)) - -(defun dired-sort-other (switches &optional no-revert) - ;; Specify new ls SWITCHES for current dired buffer. Values matching - ;; `dired-sort-by-date-regexp' or `dired-sort-by-name-regexp' set the - ;; minor mode accordingly, others appear literally in the mode line. - ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. - (setq dired-actual-switches switches) - (dired-sort-set-modeline) - (or no-revert (revert-buffer))) - -(if (eq system-type 'vax-vms) - (load "dired-vms")) - -(if (string-match "XEmacs" emacs-version) - (load "dired-xemacs-menu")) - -(run-hooks 'dired-load-hook) ; for your customizations diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/find-dired.el --- a/lisp/dired/find-dired.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,259 +0,0 @@ -;;; find-dired.el --- run a `find' command and dired the output - -;;; Copyright (C) 1992, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Roland McGrath , -;; Sebastian Kremer -;; Keywords: unix - -;; 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 -;; 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. - -;; 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. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;; To bind the following functionality to a key, put, e.g.: -;; -;; (global-set-key "\C-cf" 'find-dired) -;; (global-set-key "\C-cn" 'find-name-dired) -;; (global-set-key "\C-cl" 'find-grep-dired) -;; -;; in your ~/.emacs. - -;;; Code: - -(require 'dired) - -;; find's -ls corresponds to these switches. -;; Note -b, at least GNU find quotes spaces etc. in filenames -;;;###autoload -(defvar find-ls-option (purecopy - ;; XEmacs: add purecopy - (if (eq system-type 'berkeley-unix) '("-ls" . "-gilsb") - '("-exec ls -ld {} \\;" . "-ld"))) - "*Description of the option to `find' to produce an `ls -l'-type listing. -This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION -gives the option (or options) to `find' that produce the desired output. -LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output.") - -;;;###autoload -(defvar find-grep-options (purecopy - ;; XEmacs: add purecopy - (if (eq system-type 'berkeley-unix) "-s" "-q")) - "*Option to grep to be as silent as possible. -On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it. -On other systems, the closest you can come is to use `-l'.") - -;; XEmacs additions: next two variables. - -;;;###autoload -(defvar find-dired-multiple-buffers nil - "*If non-nil, generates a new buffer for each find") - -(defvar find-dired-dir-history nil - "History of directories used by find-dired") - -(defvar find-args nil - "Last arguments given to `find' by \\[find-dired].") - -(defvar find-args-history nil - "Last arguments given to `find' by \\[find-dired].") - -;; XEmacs: various changes in next function. - -;;;###autoload -(defun find-dired (dir args) - "Run `find' and go into dired-mode on a buffer of the output. -The command run (after changing into DIR) is - - find . \\( ARGS \\) -ls" - (interactive (list (read-file-name "Run find in directory: " - nil "" t nil 'find-dired-dir-history) - (if (featurep 'gmhist) - (read-with-history-in 'find-args-history - "Run find (with args): ") - (read-string "Run find (with args): " - (or (and (fboundp 'symbol-near-point) - (symbol-near-point)) - (car find-args-history)) - 'find-args-history)))) - ;; Expand DIR ("" means default-directory), and make sure it has a - ;; trailing slash. - (setq dir (file-name-as-directory (expand-file-name dir))) - ;; Check that it's really a directory. - (or (file-directory-p dir) - (error "find-dired needs a directory: %s" dir)) - (switch-to-buffer-other-window (if find-dired-multiple-buffers - (generate-new-buffer (concat "*Find-in-" - (file-name-nondirectory (directory-file-name dir)) - "/..*")) - (get-buffer-create "*Find*"))) - (widen) - (kill-all-local-variables) - (setq buffer-read-only nil) - (erase-buffer) - (setq default-directory dir - find-args args ; save for next interactive call - args (concat "find . " - (if (string= args "") - "" - (concat "\\( " args " \\) ")) - (car find-ls-option))) - ;; The next statement will bomb in classic dired (no optional arg allowed) - (dired-mode dir (cdr find-ls-option)) - ;; This really should rerun the find command, but I don't - ;; have time for that. - (let ((keymap (make-sparse-keymap))) - (set-keymap-parents keymap (list (current-local-map))) - (define-key keymap "g" 'undefined) - (use-local-map keymap)) - ;; Set subdir-alist so that Tree Dired will work: - (if (fboundp 'dired-simple-subdir-alist) - ;; will work even with nested dired format (dired-nstd.el,v 1.15 - ;; and later) - (dired-simple-subdir-alist) - ;; else we have an ancient tree dired (or classic dired, where - ;; this does no harm) - (set (make-local-variable 'dired-subdir-alist) - (list (cons default-directory (point-min-marker))))) - (setq buffer-read-only nil) - ;; Subdir headlerline must come first because the first marker in - ;; subdir-alist points there. - (insert " " dir ":\n") - ;; Make second line a ``find'' line in analogy to the ``total'' or - ;; ``wildcard'' line. - (insert " " args "\n") - ;; Start the find process - (message "Searching .... (but you can continue other work)") - (sit-for 0) - (let ((proc (start-process-shell-command "find" (current-buffer) args))) - (set-process-filter proc (function find-dired-filter)) - (set-process-sentinel proc (function find-dired-sentinel)) - ;; Initialize the process marker; it is used by the filter. - (move-marker (process-mark proc) 1 (current-buffer))) - (setq modeline-process '(": %s"))) - -;;;###autoload -(defun find-name-dired (dir pattern) - "Search DIR recursively for files matching the globbing pattern PATTERN, -and run dired on those files. -PATTERN is a shell wildcard (not an Emacs regexp) and need not be quoted. -The command run (after changing into DIR) is - - find . -name 'PATTERN' -ls" - (interactive - "DFind-name (directory): \nsFind-name (filename wildcard): ") - (find-dired dir (concat "-name '" pattern "'"))) - -;; This functionality suggested by -;; From: oblanc@watcgl.waterloo.edu (Olivier Blanc) -;; Subject: find-dired, lookfor-dired -;; Date: 10 May 91 17:50:00 GMT -;; Organization: University of Waterloo - -(defalias 'lookfor-dired 'find-grep-dired) - -;; XEmacs addition -(defvar find-grep-dired-history nil - "history for find-grep-dired input") - -;;;###autoload -(defun find-grep-dired (dir args) - "Find files in DIR containing a regexp ARG and start Dired on output. -The command run (after changing into DIR) is - - find . -type f -exec test -r {} \\\; -exec egrep -s ARG {} \\\; -ls - -Thus ARG can also contain additional grep options." - (interactive - ;; XEmacs improvements here. - (list (read-string "Find-grep (directory): " - default-directory 'find-dired-dir-history) - (read-string "Find-grep (grep args): " (and (fboundp 'symbol-near-point) - (symbol-near-point)) - 'find-grep-dired-history))) - ;; find -exec doesn't allow shell i/o redirections in the command, - ;; or we could use `grep -l >/dev/null' - (find-dired dir - ;; XEmacs improvements here. - (concat "-type f -exec test -r {} \\\; -exec egrep " - find-grep-options " " args " {} \\\; "))) - -(defun find-dired-filter (proc string) - ;; Filter for \\[find-dired] processes. - (let ((buf (process-buffer proc))) - (if (buffer-name buf) ; not killed? - (save-excursion - (set-buffer buf) - (save-restriction - (widen) - (save-excursion - (let ((buffer-read-only nil) - (end (point-max))) - (goto-char end) - (insert string) - (goto-char end) - (or (looking-at "^") - (forward-line 1)) - (while (looking-at "^") - (insert " ") - (forward-line 1)) - ;; Convert ` ./FILE' to ` FILE' - ;; This would lose if the current chunk of output - ;; starts or ends within the ` ./', so back up a bit: - (goto-char (- end 3)) ; no error if < 0 - (while (search-forward " ./" nil t) - (delete-region (point) (- (point) 2))) - ;; Find all the complete lines in the unprocessed - ;; output and process it to add text properties. - (goto-char end) - (if (search-backward "\n" (process-mark proc) t) - (progn - (dired-insert-set-properties (process-mark proc) - (1+ (point))) - (move-marker (process-mark proc) (1+ (point))))) - )))) - ;; The buffer has been killed. - (delete-process proc)))) - -(defun find-dired-sentinel (proc state) - ;; Sentinel for \\[find-dired] processes. - (let ((buf (process-buffer proc))) - (if (buffer-name buf) - (save-excursion - (set-buffer buf) - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-max)) - (insert "\nfind " state) - (forward-char -1) ;Back up before \n at end of STATE. - (insert " at " (substring (current-time-string) 0 19)) - (forward-char 1) - (setq modeline-process ;; XEmacs: newer spelling - (concat ":" - (symbol-name (process-status proc)))) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc) - (redraw-modeline))) ;; XEmacs function - (message "find-dired %s finished." (current-buffer)))))) - -(provide 'find-dired) - -;;; find-dired.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/gmhist-app.el --- a/lisp/dired/gmhist-app.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,237 +0,0 @@ -;;;; gmhist-app.el - applications of gmhist for some standard commands -;;;; Id: gmhist-app.el,v 4.16 1992/02/26 14:32:27 sk RelBeta - -;;;; The following commands are redefined to get history: -;;;; keep-lines -;;;; flush-lines -;;;; how-many -;;;; occur -;;;; => regexp-history -;;;; grep => grep-history -;;;; shell-command -;;;; shell-command-on-region -;;;; => shell-history -;;;; eval-expression => eval-expression-history -;;;; compile => compile-history - -;;;; You probably want to establish this key binding in your ~/.emacs, -;;;; it will make `M-x M-p' equivalent to `C-x ESC': - -;;;; (define-key esc-map "x" 'gmhist-execute-extended-command) -;;;; (define-key esc-map "X" 'execute-extended-command) ; save old M-x command - -;;;; The second line is to save the old M-x command under M-X, just in -;;;; case anything goes wrong. - -(require 'gmhist) - -;;; gmhist modifications for replace.el (preloaded). - -(mapcar '(lambda (x) - (gmhist-make-magic x 'regexp-history)) - (if gmhist-emacs-19-p - '(keep-lines flush-lines how-many) - '(keep-lines flush-lines how-many occur))) - - -(if gmhist-emacs-19-p - (progn - (gmhist-replace-spec - 'occur - '(gmhist-interactive "sList lines matching regexp: \nP" - 'regexp-history)) - (gmhist-replace-spec - 'grep - '(list (read-with-history-in - 'grep-history ; or 'regexp-history? - (concat "Run " - (substring grep-command 0 - (string-match "[\t ]+" grep-command)) - " (with args): ") - )))) - ;; else - (gmhist-make-magic 'grep 'grep-history)) - -;;; gmhist modification for simple.el (is preloaded) - -(if gmhist-emacs-19-p - (progn - (gmhist-replace-spec - 'shell-command - '(gmhist-interactive "sShell command: \nP" 'shell-history)) - (gmhist-replace-spec - 'shell-command-on-region - '(gmhist-interactive "r\nsShell command on region: \nP\np" - 'shell-history)) - ) - (gmhist-make-magic 'shell-command 'shell-history) - (gmhist-make-magic 'shell-command-on-region 'shell-history) - ) -(gmhist-make-magic 'eval-expression) - -;;; gmhist modification for compile.el (autoloaded) - -;; Often people make the variable compile-command buffer-local. -;; -;; Instead of compile-command, you now have compile-history, which is -;; initialized to -;; -;; (list compile-command) -;; -;; but afterwards gmhist ignores compile-command. So your old file -;; local variable sections or mode hooks will cease to work. -;; -;; Here is a solution: Make compile-history instead of compile-command -;; buffer-local (in a local var section of a file or in a hook, using -;; function make-local-variable). If you only sometimes have gmhist -;; loaded, make both variables buffer-local. - -;; (gmhist-make-magic 'compile 'compile-history) won't work because -;; the interactive spec is not a string. Instead, hand-craft it: - -(gmhist-replace-spec - 'compile - '(list - (read-with-history-in 'compile-history "Compile command: "))) -;; instead of... -;;(put 'compile-history 'default compile-command) -;; ... do the following -(put 'compile-history 'backup t) ; requires at least gmhist 3.22 -(put 'compile-history 'no-default t) -(put 'compile-history 'initial-hist (list compile-command)) -(put 'compile-history 'cursor-end t) - -;;; gmhist modifications for tags.el (is autoloaded) -;;; The distributed version of tags.el does not support a load hook. -;;; Add the statement -;;; (run-hooks 'tags-load-hook) -;;; at the very end of tags.el. - -(defvar tags-history nil - "History of tags.") - -(setq tags-load-hook - ;; redefine find-tag-tag upon loading of tags.el - '(lambda () - (fset 'find-tag-tag 'gmhist-find-tag-tag))) - -(defun gmhist-find-tag-tag (string) - ;; compare these two lines to the original definition... - (let ((defalt (find-tag-default))) - (if (and defalt - (string-match "[:']$" defalt)) - (setq defalt (substring defalt 0 -1))) - (put 'tags-history 'default defalt) - ;; so that M-p lets you edit the default - (setq tags-history (cons defalt tags-history)) - (list (read-with-history-in 'tags-history string)))) - -;; Gmhist version of M-x - -;; Make M-x have history (it actually has one already, but only through -;; C-x ESC (repeat-complex-command), not via M-p within the M-x -;; prompt.) - -;; execute-extended-command must be rewritten if minibuffer history is -;; implemented in C. Probably call-interactively too. - -(defvar gmhist-execute-extended-command-map (copy-keymap gmhist-completion-map) - "Keymap used inside `gmhist-execute-extended-command'.") - -;; We have to define custom version of RET and SPC (actually TAB as -;; well) since they behave completely different immediately after M-x -;; (reading a command) or after the history postion has been changed -;; to a non-zero value (editing an s-expr, an old command with its -;; arguments). - -(define-key gmhist-execute-extended-command-map - "\r" 'gmhist-execute-extended-command-exit) - -(define-key gmhist-execute-extended-command-map - " " 'gmhist-execute-extended-command-space) - -(defun gmhist-execute-extended-command-exit () - "Maybe complete the minibuffer contents, and exit. -Completes commands before exiting, but leaves command history items alone." - ;; Completion (over the set of commands) only occurs if - ;; minibufer-history-position is 0, meaning we are editing a command - ;; name. Non-zero history positions mean we are editing an sexp - ;; resulting from an earlier command and its argument, and - ;; completion is not meaningful. - (interactive) - (if (equal 0 minibuffer-history-position) - ;; Rather than calling minibuffer-complete-and-exit directly, - ;; account for the possibility that e.g. a partial completion - ;; has been loaded and changed the bindings - (funcall (lookup-key minibuffer-local-must-match-map "\C-m")) - (exit-minibuffer))) - -(defun gmhist-execute-extended-command-space () - (interactive) - (if (equal 0 minibuffer-history-position) - (funcall (lookup-key minibuffer-local-must-match-map " ")) - (insert " "))) - -(defun gmhist-execute-extended-command () ; M-x - "Read function name, then read its arguments and call it. -You can use all gmhist commands (see variable gmhist-completion-map), -especially \\\\[gmhist-previous] to backup in command-history." - (interactive) - ;; We don't want '(gmhist-execute-extended-command (quote COMMAND)) - ;; on the command history, since this is ugly, and COMMAND itself is - ;; always right next to it. This is so because - ;; gmhist-execute-extended-command is not a builtin like - ;; execute-extended-command and thus is itself entered on the - ;; command-history. - (if (assq 'gmhist-execute-extended-command command-history) - (let ((list command-history) - elt) - (while list - (setq elt (car list)) - (if (eq (car-safe elt) 'gmhist-execute-extended-command) - ;; destructively remove this elt from command-history - (progn - (setcar list nil) - ;; and exit the loop since if we're doing this each time - ;; there shouldn't be more than one such elt - the one - ;; from the last time - (setq list nil)) - (setq list (cdr list)))) - (setq command-history (delq nil command-history)))) - (let (cmd) - (let ((minibuffer-completion-confirm nil) - ;; We only need read-with-history-in here to make M-p available, - ;; the new command will be recorded below - (minibuffer-history-read-only t)) - (put 'command-history 'cursor-end t) - ;; command-history is maintained automatically: - (put 'command-history 'hist-ignore ".*") - (put 'command-history 'no-default t) - (put 'command-history 'completion-table obarray) - (put 'command-history 'hist-map gmhist-execute-extended-command-map) - (put 'command-history 'completion-predicate 'commandp) - (put 'command-history 'backup nil) - (setq cmd - (read-with-history-in - 'command-history - (if current-prefix-arg - (format "%s M-x " - current-prefix-arg - ;; this is not exactly like the original M-x - ;; but the following doesn't seem to work right -; (cond ((eq '(4) current-prefix-arg) -; "C-u") -; (t -; (prefix-numeric-value current-prefix-arg))) - ) - "M-x ") - nil t))) - (if (commandp cmd) - (let ((prefix-arg current-prefix-arg)) - (setq this-command cmd) - (command-execute cmd t)) - ;; else it is a lisp form from the history of old commands - (prog1 - (eval cmd) - (setq command-history (cons cmd command-history)))))) - diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/gmhist-cmp.el --- a/lisp/dired/gmhist-cmp.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -;; gmhist-cmp.el - -;; Gmhist support for completer.el by ccm@CS.CMU.EDU (Christopher McConnell). -;; This is known to work with version 3.01 of completer.el. - -;; You only need this when you don't like it that TAB and SPC complete -;; partially and rather want M-TAB and M-SPC do that, leaving normal -;; completion on TAB and SPC. - -;; Do partial filename completion only with M-SPC and M-TAB (SPC and -;; TAB do usual completion) within gmhist's version of read-file-name. - -(require 'completer) ; let it mung the keymaps - -;; Establish a filename key map separate from the other gmhist maps: -(setq completer-complete-filenames t - gmhist-filename-completion-map 'gmhist-completer-filename-completion-map - gmhist-filename-must-match-map 'gmhist-completer-filename-must-match-map) - -;; Fill the map with completer and gmhist key bindings: -(setq gmhist-completer-filename-must-match-map - (copy-keymap minibuffer-local-must-match-map) - gmhist-completer-filename-completion-map - (copy-keymap minibuffer-local-completion-map)) -(mapcar - '(lambda (map) - (gmhist-define-keys map) - (define-key map "\e\t" 'completer-complete) - (define-key map "\e " 'completer-word) - (define-key map "\t" 'minibuffer-complete) - (define-key map " " 'minibuffer-complete-word)) - (list gmhist-completer-filename-completion-map - gmhist-completer-filename-must-match-map)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/gmhist-mh.el --- a/lisp/dired/gmhist-mh.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,354 +0,0 @@ -;;;; gmhist-mh.el - emulate proposed Emacs 19 builtin Minibuffer History -;;;; Id: gmhist-mh.el,v 4.8 1991/09/20 13:15:40 sk RelBeta - -;;;; This package redefines the functions -;;;; -;;;; read-string -;;;; completing-read -;;;; write-region -;;;; delete-file -;;;; read-buffer -;;;; read-file-name -;;;; switch-to-buffer -;;;; -;;;; to implement the variables -;;;; -;;;; minibuffer-history-symbol -;;;; file-history-symbol -;;;; buffer-history-symbol -;;;; buffer-history-lru-order -;;;; max-minibuffer-history-length -;;;; -;;;; and the hooks -;;;; -;;;; after-write-region-hook -;;;; after-delete-file-hook - -(require 'gmhist) -(provide 'gmhist-mh) - -(defvar max-minibuffer-history-length 'not-implemented) - -;;;; Redefining basic Emacs functions - -(defun gmhist-overwrite (fun) - ;; Overwrite FUN (a symbol, the name of a function) with gmhist-new-FUN. - ;; Save the old def of FUN in gmhist-old-FUN. - ;; Conventions: gmhist-FUN emulates FUN, but with history. - ;; gmhist-new-FUN may take additional care of the case - ;; that history is disabled before calling gmhist-FUN - ;; to do the real work. - (let* ((fun-name (symbol-name fun)) - (old-name (intern (concat "gmhist-old-" fun-name))) - (new-name (intern (concat "gmhist-new-" fun-name)))) - (or (fboundp old-name) - (fset old-name (symbol-function fun))) - (fset fun new-name))) - -;;; Minibuffer history (not specialized like file or buffer history) - -;;; Should perhaps modify minibuffer keymaps directly: -;;; minibuffer-local-completion-map -;;; minibuffer-local-map -;;; minibuffer-local-must-match-map -;;; minibuffer-local-ns-map - -(defun gmhist-new-read-string (gnrs-prompt &optional initial-input) - "Read a string from the minibuffer, prompting with string PROMPT. -If non-nil second arg INITIAL-INPUT is a string to insert before reading. -See also `minibuffer-history-symbol'." - (if minibuffer-history-symbol - (gmhist-read-from-minibuffer gnrs-prompt initial-input gmhist-map) - (gmhist-old-read-string gnrs-prompt initial-input))) - -(gmhist-overwrite 'read-string) - -(defun gmhist-new-completing-read - (gncr-prompt table &optional predicate mustmatch initial) - "Read a string in the minibuffer, with completion and history. -Args are PROMPT, TABLE, PREDICATE, REQUIRE-MATCH and INITIAL-INPUT. -PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray (see - try-completion). -PREDICATE limits completion to a subset of TABLE see try-completion - for details. -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE. - If it is also not t, Return does not exit if it does non-null completion. -If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. -Case is ignored if ambient value of completion-ignore-case is non-nil. - -*** This is the gmhist version *** -See variable `minibuffer-history-symbol'." - (if minibuffer-history-symbol - (gmhist-completing-read gncr-prompt table predicate mustmatch initial) - (gmhist-old-completing-read gncr-prompt table predicate mustmatch initial))) - -(gmhist-overwrite 'completing-read) - -;;; File history - -(defvar file-history (get file-history-symbol 'initial-hist) - "Default history of file names read with read-file-name. -This symbol is the default value of file-history-symbol (q.v.).") - -(defvar insert-file-default nil - "*If non-nil, defaults for filenames will be inserted into the -minibuffer prompt. This has the advantage of putting the default onto -the file-history (which see).") - -(defun gmhist-new-read-file-name (gnrfn-prompt - &optional dir default mustmatch initial) - "Read file name, maintaining history in value of -file-history-symbol, prompting with PROMPT, completing in directory DIR. - -Value is not expanded! You must call expand-file-name yourself. - -Default name to third arg DEFAULT if user enters a null string. -\(If DEFAULT is omitted, the visited file name is used.) - -Fourth arg MUSTMATCH non-nil means require existing file's name. -Non-nil and non-t means also require confirmation after completion. - -Fifth arg INITIAL specifies text to start with. -DIR defaults to current buffer's default-directory. - -*** This is the gmhist version *** - -It differs from the original read-file-name in providing a -history of filenames in the variable whose name is the value of -file-history-symbol (usually 'file-history) (both of which see). - -INITIAL defaults to default-directory's value if -insert-default-directory is non-nil. Also, if insert-file-default is -non-nil, it inserts the DEFAULT string if no INITIAL is given, which -has the advantage of putting the default onto the file-history. -However, setting INITIAL to a string is a way for providing an -editable default, something not possible with (pre Emacs-19) -read-file-name. Setting INITIAL and insert-default-directory to nil -will yield a basename for the file, relative to default-directory. - -See function read-with-history-in for a list of properties you can put -on file-history-symbol." - (if (null file-history-symbol) - (gmhist-old-read-file-name gnrfn-prompt dir default mustmatch) - (gmhist-read-file-name gnrfn-prompt dir default mustmatch - (if (and insert-file-default - (not initial)) - default - initial)))) - -;; It is a shame that none of the standard hooks are defvar'd! -;; Also, the coexistence of `hooks' vs `hook' is annoying. -;; The singular seems to be the majority, so I'll use that. - -(defvar after-write-region-hook nil - "Run after the gmhist version of `write-region'. -The variables `start', `end', `filename', `append', `visit' are bound -around the call to the hook.") - -;; Don't use &rest args, as the hook may want to take advantage of our -;; arglist. -(defun gmhist-new-write-region (start end filename - &optional append visit) - "Write current region into specified file. -When called from a program, takes three arguments: -START, END and FILENAME. START and END are buffer positions. -Optional fourth argument APPEND if non-nil means - append to existing file contents (if any). -Optional fifth argument VISIT if t means - set last-save-file-modtime of buffer to this file's modtime - and mark buffer not modified. -If VISIT is neither t nor nil, it means do not print - the \"Wrote file\" message. - -*** This is the gmhist version *** -See variable `after-write-region-hook'." - (interactive "r\nFWrite region to file: ") - (prog1 - (gmhist-old-write-region start end filename append visit) - (condition-case err - ;; basic-save-buffer would assume an error to mean - ;; write-region failed - (run-hooks 'after-write-region-hook) - (error (message "Error in after-write-region-hook %s" err) - (sit-for 1))))) - -(defvar after-delete-file-hook nil - "Run after the gmhist version of `delete-file'. -The hook is run with `filename' bound to the filename.") - -(defun gmhist-new-delete-file (filename) - "Delete specified file. One argument, a file name string. -If file has multiple names, it continues to exist with the other names. - -*** This is the gmhist version *** -See variable `after-delete-file-hook'." - (interactive "fDelete file: ") - (prog1 - (gmhist-old-delete-file filename) - (condition-case err - ;; We don't want callers to assume an error in the hook to - ;; mean delete-file failed - or do we? - (run-hooks 'after-delete-file-hook) - (error (message "Error in after-delete-file-hook %s" err) - (sit-for 1))))) - -(gmhist-overwrite 'read-file-name) -(gmhist-overwrite 'write-region) -(gmhist-overwrite 'delete-file) - -;; Redefining read-file-name does not suffice as interactive "f" -;; calls the C version of read-file-name. -;; gmhist-interactive of gmhist.el,v 4.4 and later understands the -;; indirection from file-history-symbol to 'file-history (or whatever -;; the current value may be). -(gmhist-make-magic 'find-file 'file-history-symbol) -(gmhist-make-magic 'find-file-other-window 'file-history-symbol) -(gmhist-make-magic 'find-file-read-only 'file-history-symbol) -(gmhist-make-magic 'insert-file 'file-history-symbol) -(gmhist-make-magic 'load-file 'file-history-symbol) -(gmhist-make-magic 'set-visited-file-name 'file-history-symbol) -(gmhist-make-magic 'append-to-file 'file-history-symbol) -;; write-region is wrapped by gmhist, no longer a subr, thus this works: -(gmhist-make-magic 'write-region 'file-history-symbol) -;; ditto for delete-file: -(gmhist-make-magic 'delete-file 'file-history-symbol) -(if gmhist-emacs-19-p - ;; In Emacs 19, these call the redefined read-file-name inside - ;; interactive, so we don't need to do anything - nil - (gmhist-make-magic 'write-file 'file-history-symbol) - (gmhist-make-magic 'find-alternate-file 'file-history-symbol)) - - -;;; Buffer history - -(defvar buffer-history-lru-order nil - "*If non-nil, the buffer history will be the complete buffer -list in most recently used order (as returned by buffer-list). - -Usually, the buffer history is in the order entered using read-buffer.") - -(defvar buffer-history (get 'buffer-history 'initial-hist) - "History of all buffer names read with read-buffer.") - -(defun gmhist-new-read-buffer (gnrb-prompt &optional default existing) - "One arg PROMPT, a string. Read the name of a buffer and return as a string. -Prompts with PROMPT. -Optional second arg is value to return if user enters an empty line. -If optional third arg REQUIRE-MATCH is non-nil, only existing buffer names are allowed. - -*** This is the gmhist version *** - -See variables `buffer-history-symbol' and `buffer-history-lru-order'." - (if (and buffer-history-symbol - buffer-history-lru-order) - (set buffer-history-symbol - (mapcar (function buffer-name) (buffer-list)))) - (gmhist-read-buffer gnrb-prompt default existing)) - -(defun gmhist-new-switch-to-buffer (buffer &optional norecord) - "Select buffer BUFFER in the current window. -BUFFER may be a buffer or a buffer name. -Optional second arg NORECORD non-nil means -do not put this buffer at the front of the list of recently selected ones. - -WARNING: This is NOT the way to work on another buffer temporarily -within a Lisp program! Use `set-buffer' instead. That avoids messing with -the window-buffer correspondences. - -*** This is the gmhist version *** - -It adds buffer-history to switch-to-buffer." - (interactive - ;; should perhaps bypass gmhist if NORECORD is given? - (list (gmhist-new-read-buffer "Switch to buffer: " (other-buffer) nil))) - (gmhist-old-switch-to-buffer buffer norecord)) - -(gmhist-overwrite 'read-buffer) -;; switch-to-buffer is a subr: -(gmhist-overwrite 'switch-to-buffer) -;; Redefining read-buffer does not suffice as interactive "b" -;; calls the C version of read-buffer. -;; gmhist-interactive of gmhist.el,v 4.4 and later understands the -;; indirection from buffer-history-symbol to 'buffer-history (or -;; whatever the current value may be). -(mapcar (function (lambda (fun) - (gmhist-make-magic fun 'buffer-history-symbol))) - '(switch-to-buffer-other-window ; files.el - append-to-buffer ; the rest from simple.el - prepend-to-buffer - copy-to-buffer)) - - -;;; read-from-minibuffer -;;; saved and defined in gmhist.el, just need to overwrite: - -(fset 'read-from-minibuffer 'gmhist-new-read-from-minibuffer) - -;; Now that we've redefined read-from-minibuffer we need to make sure -;; that repeat-complex-command (C-x ESC), which calls -;; read-from-minibuffer, adds the command to command-history and not -;; to the ambient value of minibuffer-history-symbol. The latter -;; could be confusing if e.g. inside a C-x C-f a C-x ESC is done (with -;; enable-recursive-minibuffers t): it would add a command to the -;; file-history. - -;(defun repeat-complex-command (repeat-complex-command-arg) -; "Edit and re-evaluate last complex command, or ARGth from last. -;A complex command is one which used the minibuffer. -;The command is placed in the minibuffer as a Lisp form for editing. -;The result is executed, repeating the command as changed. -;If the command has been changed or is not the most recent previous command -;it is added to the front of the command history. -;Whilst editing the command, the following commands are available: -;\\{repeat-complex-command-map}" -; (interactive "p") -; (let ((elt (nth (1- repeat-complex-command-arg) command-history)) -; newcmd) -; (if elt -; (progn -; (setq newcmd -; (let ((minibuffer-history-symbol nil)) -; ;; Don't let gmhist interfere with command-history. -; ;; command-history is special because it's builtin to M-x. -; ;; Also, gmhist would store commands as strings, not -; ;; as s-exprs. -; ;; When gmhist is implemented in C, M-x must be -; ;; fixed to store strings, too. -; (read-from-minibuffer "Redo: " -; (prin1-to-string elt) -; repeat-complex-command-map -; t))) -; ;; If command to be redone does not match front of history, -; ;; add it to the history. -; (or (equal newcmd (car command-history)) -; (setq command-history (cons newcmd command-history))) -; (eval newcmd)) -; (ding)))) - -;; Actually, it's easier to just use the gmhist re-implementation instead -(define-key ctl-x-map "\e" 'gmhist-repeat-complex-command) - -(defun gmhist-repeat-complex-command (arg) ; C-x ESC - ;; This function from Mike Williams - "Edit and re-evaluate last complex command, or ARGth from last. -A complex command is one which used the minibuffer. -The command is placed in the minibuffer as a Lisp form for editing. -The result is executed, repeating the command as changed. -If the command has been changed or is not the most recent previous command -it is added to the front of the command history." - (interactive "p") - (let ((print-escape-newlines t)) - (put 'command-history 'backup arg) - (put 'command-history 'cursor-end t) - (eval (read-with-history-in 'command-history "Redo: " nil 'lisp)) - (put 'command-history 'backup nil))) - -;; TODO: -;; read-minibuffer -;; eval-minibuffer -;; read-no-blanks-input -;; read-command -;; read-variable diff -r 498bf5da1c90 -r 0d2f883870bc lisp/dired/gmhist.el --- a/lisp/dired/gmhist.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1071 +0,0 @@ -;;;; gmhist.el - Provide generic minibuffer history for commands - -(defconst gmhist-version (substring "!Revision: 4.27 !" 11 -2) - "Id: gmhist.el,v 4.27 1992/04/20 17:17:47 sk RelBeta -Report bugs to Sebastian Kremer .") - -;; Copyright (C) 1990 by Sebastian Kremer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; gmhist|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Generic minibuffer history package. -;; |Date: 1992/04/20 17:17:47 |Revision: 4.27 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your -;; ~/.emacs: -;; -;; (autoload 'read-with-history-in "gmhist") -;; (autoload 'read-file-name-with-history-in "gmhist") -;; (autoload 'completing-read-with-history-in "gmhist") -;; (autoload 'gmhist-make-magic "gmhist" nil t) - -;; USAGE ============================================================= -;; -;; - as an Elisp programmer: use functions read-with-history-in, -;; completing-read-with-history-in, read-file-name-with-history-in or -;; gmhist-interactive inside the interactive clause of your functions -;; instead of a string specification. See the examples at the end of -;; the file. -;; -;; - as an Emacs user: To provide `simple' functions with history, -;; just type M-x gmhist-make-magic and enter the name of the -;; function, e.g., `eval-expression'. This function's arguments -;; are then remembered across calls and are available by typing -;; M-p to the minibuffer prompt of the function. More history -;; commands are mentioned in the documentation of variable -;; gmhist-map. -;; -;; Type M-x gmhist-remove-magic to restore the function's old -;; interactive behaviour. -;; -;; `Simple' functions are those that prompt for strings, file -;; names or lisp objects and perhaps use prefix args and the -;; region. See the file gmhist-app.el for examples with simple -;; and other functions. - -;; I'd like to thank Jamie Zawinski, Piet van Oostrum and Mike -;; Williams for very helpful feedback and ideas. - - -(provide 'gmhist) - -;; Emacs 19 has s-expr interactive's on some functions (sometimes to -;; emulate functionality gmhist would give). So we sometimes have to -;; test this to avoid letting gmhist-make-magic bombing on non-string -;; interactive specifications: -;; XEmacs fix: -(defvar gmhist-emacs-19-p (not (equal (substring emacs-version 0 2) "18"))) - -(defvar gmhist-default-format "[%s] " ; saves screen space, too - "Format used by gmhist to indicate the presence of a default value. -Set this to \"(default %s) \" to get the standard format.") - -(defvar gmhist-search-history nil "History of history searches.") - -(defun read-with-history-in (GMHIST-SYMBOL rwhi-prompt &optional - GMHIST-INITIAL GMHIST-READ) - ;; We have to be careful about dynamical scoping here so as not to - ;; shadow other lisp code that depends on fluid vars like `prompt - ;; (notorious in minibuffer code, e.g. electric-replace). - ;; That's why our own fluid vars have upper-case names starting with - ;; GMHIST- and why `rwhi-prompt' instead of `prompt' is used as - ;; formal argument. Similar below. - "\ -Read a string, maintaining minibuffer history across calls in GMHIST-SYMBOL, - prompting with PROMPT, with optional GMHIST-INITIAL as initial contents. -If optional fourth arg GMHIST-READ is non-nil, then interpret the - result as a lisp object and return that object. -See variable gmhist-map for history commands available during edit. -Example: - (defun foo-command (cmd) - (interactive (list (read-with-history-in 'foo-history \"Foo: \" ))) - (message \"Fooing %s...\" cmd)) - -See function gmhist-make-magic on how to give an existing function -history. - -These properties (see function put) of GMHIST-SYMBOL are supported: - -cursor-end Put cursor at end of a newly retrieved history line. -cursor-pos A regexp to put the cursor on. -keep-dups If t, duplicate commands are remembered, too. -initial-hist Initial value of the history list. -hist-ignore Regexp of commands that are not to be added to the history. -backup If t, backup in the history list (as if user had typed - M-p as first thing). Can also be an integer to backup - more than one history item. -default An empty string as input will default to the last - command (whether the last command was added to the - history or not). The default is stored in this - property, thus its initial value is the first default. -dangerous Commands matching this regexp will never be the default. -no-default If you don't want defaults at all, set this to t. - -Use the following only if you know what you are doing: - -hist-function Name of a function to call instead of doing normal - history processing. read-with-history-in becomes - effectively an alias for this function. - -These will be flushed soon (use let-binding minibuffer-completion-table -etc. instead): - -hist-map Minibuffer key map to use instead of gmhist-map. -completion-table -completion-predicate - Used in completion on history strings, when the hist-map - property has gmhist-completion-map as value. - The special value `t' for the table means to use the - current history list. - Thus, to get completion on history items just do: - (put 'foo-history 'hist-map gmhist-completion-map) - (put 'foo-history 'completion-table t) - -Hooks: - gmhist-after-insert-hook is run after a history item is - inserted into the minibuffer. - gmhist-load-hook is run after this package is loaded. - gmhist-hook is run as first thing inside read-with-history-in. - gmhist-before-move-hook is run before history motion takes place. - Function gmhist-remember-zero is a candidate for that hook. -" - ;; We don't use property names prefixed with 'ghmist-' because the - ;; caller has freedom to use anything for GMHIST-SYMBOL. - ;; The history list is never truncated, but I don't think this will - ;; cause problems. All histories together have at most a few k. - ;; On the other hand, some people run an Emacs session for weeks. - ;; Could use gmhist-hook to truncate the current history list. - ;; You can use 'initial-hist to save (part of) the history in a file - ;; and provide it at next startup. [Is there an exit-emacs-hook?] - ;; You can use 'hist-function to implement a completely different - ;; history mechanism, e.g., a ring instead of a list, without having - ;; to modify existing gmhist applications. - (run-hooks 'gmhist-hook) - (let ((hist-function (get GMHIST-SYMBOL 'hist-function))) - (if (fboundp hist-function) ; hist-function must be a symbol - (funcall hist-function ; not lambda - GMHIST-SYMBOL rwhi-prompt GMHIST-INITIAL GMHIST-READ) - (or (boundp GMHIST-SYMBOL) ; history list defaults to nil - (set GMHIST-SYMBOL (get GMHIST-SYMBOL 'initial-hist))) - ;; else do the usual history processing simply using lists: - (let* ((history (symbol-value GMHIST-SYMBOL)) - (minibuffer-completion-table (let ((table - (get GMHIST-SYMBOL - 'completion-table))) - (if (eq t table) - (mapcar (function list) - history) - table))) - (minibuffer-completion-predicate (get GMHIST-SYMBOL - 'completion-predicate)) - (minibuffer-history-symbol GMHIST-SYMBOL)) - (gmhist-new-read-from-minibuffer rwhi-prompt - GMHIST-INITIAL - (or (get GMHIST-SYMBOL 'hist-map) - gmhist-map) - GMHIST-READ))))) - -(defun completing-read-with-history-in (crwhi-hist-sym &rest args) - "Like completing-read, but with additional first arg HISTORY-SYMBOL." - (let ((minibuffer-history-symbol crwhi-hist-sym)) - (apply 'gmhist-completing-read args))) - -(defun gmhist-completing-read (crwhi-prompt table - &optional predicate - mustmatch initial) - "Like completing-read, but see minibuffer-history-symbol." - (let ((minibuffer-completion-confirm (if (eq mustmatch t) nil t)) - (minibuffer-completion-table table) - (minibuffer-completion-predicate predicate)) - (gmhist-new-read-from-minibuffer crwhi-prompt - initial - (gmhist-lookup-keymap - (if mustmatch - gmhist-must-match-map - gmhist-completion-map))))) - - -(defun read-file-name-with-history-in (crwhi-hist-sym &rest args) - "Like read-file-name, but with additional first arg HISTORY-SYMBOL." - (let ((file-history-symbol crwhi-hist-sym)) - (apply 'gmhist-read-file-name args))) - -(defvar file-history-symbol 'file-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -filenames entered in the minibuffer. -You may let-bind this to another symbol around calls to read-file-name.") - -(defun gmhist-read-file-name - (grfn-prompt &optional dir default mustmatch initial) - "Args: PROMPT &optional DIR DEFAULT MUSTMATCH INITIAL. -Read file name, maintaining history in file-history-symbol, prompting - with PROMPT, with optional INITIAL input and completing in directory DIR. -Value is not expanded! You must call expand-file-name yourself. -Default name to arg DEFAULT if user enters a null string (or, if - INITIAL was given, leaves it unchanged). -MUSTMATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -DIR defaults to current buffer's default-directory. - -This function differs from read-file-name in providing a history of -filenames bound to file-history-symbol and (for pre-Emacs 19) in -providing an argument INITIAL not present in Emacs 18's read-file-name." - (setq dir (or dir default-directory) - default (or default buffer-file-name)) - (if file-history-symbol - (progn (put file-history-symbol 'cursor-end t) - (put file-history-symbol 'no-default t))) - ;; $'s should be quoted (against substitute-in-file-name) in file - ;; names inserted here - (if initial - (setq initial (gmhist-quote-dollars (gmhist-unexpand-home initial))) - (if insert-default-directory - (setq initial (gmhist-quote-dollars (gmhist-unexpand-home dir))))) - (let* ((minibuffer-completion-confirm (if (eq mustmatch t) nil t)) - (minibuffer-completion-table 'read-file-name-internal) - (minibuffer-completion-predicate dir) - (minibuffer-history-symbol file-history-symbol) - (val (gmhist-new-read-from-minibuffer - grfn-prompt initial (gmhist-lookup-keymap - (if mustmatch - gmhist-filename-must-match-map - gmhist-filename-completion-map))))) - - (or (and (or (and (stringp initial) - (string= initial val)) - (and (null initial) - (zerop (length val)))) - default) - (substitute-in-file-name val)))) - -(defun gmhist-unexpand-home (file) - ;; Make prompt look nicer by un-expanding home dir. - ;; read-file-name does this, too. - ;; Avoid clobbering match-data with string-match. - (let* ((home (expand-file-name "~/")) - (home-len (length home)) - (file-len (length file))) - (if (and home - (stringp file) - (>= file-len home-len) - (string= home (substring file 0 home-len)) - (eq ?/ (aref file (1- home-len)))) - (concat "~/" (substring file home-len)) - file))) - -; (defun gmhist-quote-dollars (file) -; "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" -; (apply (function concat) -; (mapcar (function -; (lambda (char) -; (if (= char ?$) -; "$$" -; (vector char)))) -; file))) -;; 10000 iterations of (gmhist-quote-dollars "foo") took 19 seconds -;; and *lots* of garbage collections (about a dozen or more) - -;; This version does not cons and is much faster in the usual case -;; without $ present: -;; 10000 iterations of (gmhist-quote-dollars "foo") took 4 seconds and -;; not a single garbage collection. -(defun gmhist-quote-dollars (file) - "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" - (let ((pos 0)) - (while (setq pos (string-match "\\$" file pos)) - (setq file (concat (substring file 0 pos) - "$";; precede by escape character (also a $) - (substring file pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - file)) - - - -(defun read-buffer-with-history-in (rbwhi-hist-sym &rest args) - "Like read-buffer, but with additional first arg HISTORY-SYMBOL." - (let ((buffer-history-symbol rbwhi-hist-sym)) - (apply 'gmhist-read-buffer args))) - -(defvar buffer-history-symbol 'buffer-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -buffer names entered in the minibuffer.") - -(defun gmhist-read-buffer (grb-prompt &optional default existing) - "Read a buffer name, maintaining history in buffer-history-symbol and return as string. -Args PROMPT &optional DEFAULT EXISTING. -Optional arg EXISTING means an existing buffer must be entered." - (if (bufferp default);; want string in prompt, not buffer object - (setq default (buffer-name default))) - (if buffer-history-symbol - (put buffer-history-symbol 'default default)) ; also if nil - (let* ((minibuffer-history-symbol buffer-history-symbol) - (name (gmhist-completing-read - grb-prompt - ;;(function (lambda (buf) (list (buffer-name buf)))) - ;; convert to alist in format (BUF-NAME . BUF-OBJ) - (mapcar - (function (lambda (arg) (cons (buffer-name arg) arg))) - (buffer-list)) - (function (lambda (elt) (get-buffer (car elt)))) - existing))) - (if (equal "" name) - default - name))) - -(defvar minibuffer-history-symbol 'minibuffer-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -the string entered in the minibuffer. -Input is stored as string, even for e.g. `read-buffer'.") - -(defvar minibuffer-history nil - "List of strings entered using the minibuffer, most recent first.") - -(put 'minibuffer-history 'no-default t) - -(defvar minibuffer-history-read-only nil - "If non-nil, nothing will be stored on `minibuffer-history-symbol'. -History motions commands are still available in the minibuffer.") - -(defvar minibuffer-history-position nil - "If currently reading the minibuffer, the history position.") - -(defvar minibuffer-initial-contents nil - "If currently reading the minibuffer, the initial contents.") - -;; Save the subr, we need it inside the redefined version: -(or (fboundp 'gmhist-old-read-from-minibuffer) - (fset 'gmhist-old-read-from-minibuffer - (symbol-function 'read-from-minibuffer))) - -(defun gmhist-new-read-from-minibuffer - (gnrfm-prompt &optional initial-contents keymap read position) - "Read a string from the minibuffer, prompting with string PROMPT. -If optional second arg INITIAL-CONTENTS is non-nil, it is a string - to be inserted into the minibuffer before reading input. -Third arg KEYMAP is a keymap to use whilst reading; - if omitted or nil, the default is `minibuffer-local-map'. -If fourth arg READ is non-nil, then interpret the result as a lisp object - and return that object: - in other words, do `(car (read-from-string INPUT-STRING))' -Fifth arg POSITION, if non-nil, is where to put point - in the minibuffer after inserting INITIAL-CONTENTS. - -The ambient value of `minibuffer-history-symbol' (q.v.) is used and set. - -*** This is the gmhist version.***" - (if (null minibuffer-history-symbol) - (if gmhist-emacs-19-p - (gmhist-old-read-from-minibuffer - gnrfm-prompt initial-contents keymap read position) - (gmhist-old-read-from-minibuffer gnrfm-prompt initial-contents - keymap read)) - (gmhist-read-from-minibuffer - gnrfm-prompt initial-contents keymap read position))) - -(defun gmhist-read-from-minibuffer (grfm-prompt - &optional - initial-contents keymap read position) - (or keymap (setq keymap minibuffer-local-map)) - (or minibuffer-history-read-only - (boundp minibuffer-history-symbol) ; history list defaults to nil - ;; create history list if not already done - (set minibuffer-history-symbol - (get minibuffer-history-symbol 'initial-hist))) - (let* ((minibuffer-history-position 0) ; fluid var for motion commands - (minibuffer-initial-contents initial-contents) ; ditto - (history (symbol-value minibuffer-history-symbol)) - ;; Command is an s-exp when read->t. In this case, - ;; cannot have empty input: - (no-default (or read - (get minibuffer-history-symbol 'no-default))) - (dangerous (if no-default - nil - (get minibuffer-history-symbol 'dangerous))) - ;; Idea for 'backup feature by Mike Williams - (backup (get minibuffer-history-symbol 'backup)) - (default (if no-default - nil - (get minibuffer-history-symbol 'default))) - (the-prompt (if default - (concat grfm-prompt (format gmhist-default-format - default)) - grfm-prompt)) - (the-initial (if (or minibuffer-initial-contents - (not backup)) - minibuffer-initial-contents - ;; else we must backup in the history list - (setq backup (min (max 0 (or (and (integerp backup) - backup) - 1)) - (length history))) - (if (zerop (setq minibuffer-history-position backup)) - nil - ;; else backup is at least 1 - (let ((backup-input (nth (1- backup) history))) - (if read - (prin1-to-string backup-input) - backup-input))))) - command) - ;; Read the command from minibuffer, providing history motion - ;; key map and minibuffer completion - (setq command - (if position - ;; avoid passing POSITION arg unless given (presumably - ;; we are in Emacs 19 then) - (gmhist-old-read-from-minibuffer the-prompt the-initial keymap - position) - (gmhist-old-read-from-minibuffer the-prompt the-initial keymap))) - ;; Care about default values unless forbidden: - (or no-default - (setq command (gmhist-handle-default command default dangerous))) - (if minibuffer-history-read-only - nil - (let (ignore) - ;; Add to history if first command, or not a dup, or not to be ignored - (or (and history - (or (if (get minibuffer-history-symbol 'keep-dups) - nil - (equal command (car history))) - (if (stringp (setq ignore (get minibuffer-history-symbol - 'hist-ignore))) - (string-match ignore - (gmhist-stringify (car history)))))) - (set minibuffer-history-symbol (cons command history))))) - ;; Return command's value to caller: - (if read - (car (read-from-string command)) - command))) - -(defun gmhist-handle-default (command default dangerous) - (if (string= "" command) - (if default (setq command default))) - ;; Set default value unless it is dangerous. - (or (and (stringp dangerous) - ;; Should actually save match-data as we call string-match - (string-match dangerous (gmhist-stringify command))) - (put minibuffer-history-symbol 'default command)) - ;; Return the prefrobnicated command: - command) - - -;; Minibuffer key maps to implement history - -(defvar gmhist-define-keys-hook nil - "Hook run inside function `gmhist-define-keys' (q.v.), after the -standard gmhist bindings.") - -(or (fboundp 'gmhist-define-keys) - (defun gmhist-define-keys (map) - "Bind the standard history commands in MAP, a key map. - -When gmhist is loaded, this function is only defined if you have not -already defined it, so that you can customize it without worrying -about load order. -You can also use `gmhist-define-keys-hook' if you just want to add to -existing bindings." - (define-key map "\M-p" 'gmhist-previous) - (define-key map "\M-n" 'gmhist-next) - (define-key map "\M-r" 'gmhist-search-backward) - (define-key map "\M-s" 'gmhist-search-forward) - ;;(define-key map "\M-<" 'gmhist-beginning) - ;;(define-key map "\M-<" 'gmhist-beginning) - ;; Last two for bash/readline compatibility. Better M-a and M-e ? - ;; In query-replace, multi-line text together with next-line's - ;; misfeature of adding blank lines really lets you lose without M-< - ;; and M->. - ;;(define-key map "\M-a" 'gmhist-beginning) - ;;(define-key map "\M-e" 'gmhist-end) - ;; M-a is already used in electric replace - ;; Try this as general purpose mover: - (define-key map "\M-g" 'gmhist-toggle) - (define-key map "\M-G" 'gmhist-switch-history) - (define-key map "\M-?" 'gmhist-show) - (run-hooks 'gmhist-define-keys-hook))) - -(defun gmhist-lookup-keymap (map) - (if (keymapp map) - map - (gmhist-lookup-keymap (symbol-value map)))) - -(defvar gmhist-map nil - "Key map for generic minibuffer history. -\\\\[gmhist-previous], \\[gmhist-next], \ -\\[gmhist-beginning], \\[gmhist-end] move through, \ -\\[gmhist-search-backward] and \\[gmhist-search-forward] search, -\\[gmhist-show] displays the history: -\\{gmhist-map}") - -(if gmhist-map - nil - (setq gmhist-map (copy-keymap minibuffer-local-map)) - (gmhist-define-keys gmhist-map)) - -(defvar gmhist-completion-map nil - "Key map for generic minibuffer history with completion, see gmhist-map.") - -(if gmhist-completion-map - nil - ;; If you have loaded D. Gillespie's complete.el or Christopher - ;; McConnell's completer.el *before* gmhist, you get it in gmhist, - ;; too: - (setq gmhist-completion-map (copy-keymap minibuffer-local-completion-map)) - (gmhist-define-keys gmhist-completion-map)) - -(defvar gmhist-must-match-map nil - "Key map for generic minibuffer history with completion that must match, -see gmhist-map.") - -(if gmhist-must-match-map - nil - (setq gmhist-must-match-map (copy-keymap minibuffer-local-must-match-map)) - (gmhist-define-keys gmhist-must-match-map)) - -(defvar gmhist-filename-completion-map 'gmhist-completion-map - "A keymap (or a symbol pointing to one) to use in filename -completion that need not match. Defaults to 'gmhist-completion-map.") - -(defvar gmhist-filename-must-match-map 'gmhist-must-match-map - - "A keymap (or a symbol pointing to one) to use in filename -completion that must match. Defaults to 'gmhist-must-match-map.") - - -;; Minibuffer commands to implement history -;; They run inside read-with-history-in and heavily depend on fluid -;; vars from there. - -(defun gmhist-goto (n) - ;; Go to history position N, 1 <= N <= length of history - ;; N<0 means the future and inserts an empty string - ;; N=0 means minibuffer-initial-contents (fluid var from - ;; gmhist-new-read-from-minibuffer) - (run-hooks 'gmhist-before-move-hook) - (erase-buffer) - (setq minibuffer-history-position n) - (if (< n 0) - nil - (insert - (gmhist-stringify - (if (= n 0) - (or minibuffer-initial-contents "") - (nth (1- n) (symbol-value minibuffer-history-symbol))))) - (run-hooks 'gmhist-after-insert-hook) - ;; next two actually would be a good application for this hook - (goto-char (if (get minibuffer-history-symbol 'cursor-end) - (point-max) - (point-min))) - (let ((pos (get minibuffer-history-symbol 'cursor-pos))) - (if (stringp pos) - (if (eobp) - (re-search-backward pos nil t) - (re-search-forward pos nil t)))))) - -(defun gmhist-beginning () - "Go to the oldest command in the history." - (interactive) - (gmhist-goto (length (symbol-value minibuffer-history-symbol)))) - -(defun gmhist-end () - "Position before the most recent command in the history." - (interactive) - (gmhist-goto 0)) - -(defun gmhist-toggle (&optional n) - "If at end of history, move to beginning, else move to end. -Prefix arg is history position to go to." - (interactive "P") - (if n - (gmhist-goto (prefix-numeric-value n)) - (if (= 0 minibuffer-history-position) - (gmhist-beginning) - (gmhist-end)))) - -(defun gmhist-switch-history (new-history) - "Switch to a different history." - (interactive - (let ((enable-recursive-minibuffers t)) - (list (read-from-minibuffer "Switch to history: " nil nil t)))) - (setq minibuffer-history-symbol new-history - minibuffer-history-position 0)) - -(defun gmhist-next (n) - "Go to next history position." - ;; fluid vars: minibuffer-history-symbol minibuffer-history-position - ;; Inserts the next element of minibuffer-history-symbol's value - ;; into the minibuffer. - ;; minibuffer-history-position is the current history position. - (interactive "p") - ;; clip the new history position to the valid range: - (let ((narg (min (max 0 (- minibuffer-history-position n)) - (length (symbol-value minibuffer-history-symbol))))) - (if (= minibuffer-history-position narg) - (error "No %s item in %s" - (if (= 0 minibuffer-history-position) "following" "preceding") - minibuffer-history-symbol) - (gmhist-goto narg)))) - -(defun gmhist-previous (n) - "Go to previous history position." - (interactive "p") - (gmhist-next (- n))) - -;; Searching the history - -(defun gmhist-search-backward (regexp &optional forward) - "Search backward in the history list for REGEXP. -With prefix argument, search for line that contains match for current line." - (interactive - (if current-prefix-arg - (list (regexp-quote (buffer-string))) - (let ((enable-recursive-minibuffers t)) - (list (read-with-history-in 'gmhist-search-history - "History search (regexp): "))))) - (let* (found - (direction (if forward -1 1)) - (pos (+ minibuffer-history-position direction)) ; find _next_ match! - (history (symbol-value minibuffer-history-symbol)) - (len (length history))) - (while (and (if forward (> pos 0) (<= pos len)) - (not (setq found - (string-match - regexp - (gmhist-stringify (nth (1- pos) history)))))) - (setq pos (+ pos direction))) - (or found (error "%s not found in %s" regexp minibuffer-history-symbol)) - (gmhist-goto pos))) - -(defun gmhist-search-forward (regexp &optional backward) - "Search forward in the history list for REGEXP. -With prefix argument, search for line that matches current line -instead of prompting for REGEXP." - (interactive - (if current-prefix-arg - (list (regexp-quote (buffer-string))) - (let ((enable-recursive-minibuffers t)) - (list (read-with-history-in 'gmhist-search-history - "History search forward (regexp): "))))) - (gmhist-search-backward regexp (not backward))) - -;; Misc. - -(defun gmhist-stringify (elt) - ;; If ELT is not a string, convert it to one. - (if (stringp elt) elt (prin1-to-string elt))) - -(defun gmhist-show () - "Show the history list in another buffer. -Use \\[scroll-other-window] to scroll, with negative arg to scroll back." - (interactive) - (let ((count 0)) - (with-output-to-temp-buffer (concat "*" (symbol-name minibuffer-history-symbol) "*") - (mapcar - (function - (lambda (x) - (princ (format "%2s%2d: %s\n" - (if (eq (setq count (1+ count)) - minibuffer-history-position) - "> " - " ") - count x)))) - (symbol-value minibuffer-history-symbol))))) - -(defun gmhist-remember-zero () - "Put this function on gmhist-before-move-hook to make gmhist -remember the initial value even after you edited it: - - (setq gmhist-before-move-hook 'gmhist-remember-zero)" - (if (zerop minibuffer-history-position) - (setq minibuffer-initial-contents (buffer-string)))) - -;; Hack up interactive specifications of existing functions - -(defun gmhist-copy-function (fun) - (let ((old (gmhist-symbol-function fun))) - (if (consp old) ; interpreted, or v18 compiled - ;; copy-sequence does not copy recursively. - ;; Iteration is faster than recursion, and we need just two levels - ;; to be able to use setcdr to mung the interactive spec. - (let (new elt) - (while old - (setq elt (car old) - old (cdr old) - new (cons (if (sequencep elt) - (copy-sequence elt) - elt) - new))) - (nreverse new)) - ;; else v19 compiled - (let ((new (append old nil))) - (setcar (nthcdr 5 new) (copy-sequence (aref old 5))) - (apply 'make-byte-code new))))) - -(defun gmhist-check-autoload (fun) - "If FUN is an autoload, load its definition." - (let ((lis (symbol-function fun))) - (if (and (listp lis) ; FUN could also be a subr - (eq 'autoload (car lis))) - (load (nth 1 lis))))) - -(defun gmhist-replace-spec (fun new-spec &optional copy-first) - "Replace the interactive specification of FUN with NEW-SPEC. -FUN must be a symbol with a function definition. -Autoload functions are taken care of by loading the appropriate file first. -If FUN is a pure storage function (one dumped into Emacs) it is first - copied onto itself, because pure storage cannot be modified. - Optional non-nil third arg COPY-FIRST is used internally for this. -The old spec is put on FUN's gmhist-old-interactive-spec property. - That property is never overwritten by this function. It is used by - function gmhist-remove-magic." - (gmhist-check-autoload fun) - (if copy-first ; copy (from pure storage) - (fset fun (gmhist-copy-function fun))) - (let* ((flambda (gmhist-symbol-function fun)) - (fint (and (consp flambda) - (if (eq 'interactive (car-safe (nth 2 flambda))) - (nth 2 flambda) - (if (eq 'interactive (car-safe (nth 3 flambda))) - (nth 3 flambda) - (error "%s is not interactive" fun))))) - (old-spec (if fint - (nth 1 fint) - (gmhist-spec fun)))) - ;; Save old interactive spec as property of FUN: - (or (get fun 'gmhist-old-interactive-spec) - (put fun 'gmhist-old-interactive-spec old-spec)) - ;; Replace '(interactive OLD-SPEC) with '(interactive NEW-SPEC) - (if copy-first - ;; This should not fail - if it does, we must abort. - (if (consp flambda) - (setcdr fint (list new-spec)) - ;; can't "aset" a # object, though aref works... - (setq flambda (append flambda nil)) - (setcar (nthcdr 5 flambda) new-spec) - (setq flambda (apply 'make-byte-code flambda)) - (fset fun flambda)) - ;; else prepare for a second try - (condition-case err - (setcdr fint (list new-spec)) - (error - ;; Setcdr bombs on preloaded functions: - ;; (error "Attempt to modify read-only object") - ;; There seems to be no simple way to test whether an object - ;; resides in pure storage, so we let it bomb and try again - ;; after copying it into writable storage. - (gmhist-replace-spec fun new-spec t)))))) - -(defun gmhist-spec (fun) - "Get the current interactive specification for FUN (a symbol). -Signal an error if FUN is not interactive." - (let ((flambda (gmhist-symbol-function fun)) - fint) - (cond ((consp flambda) ; interpreted, or v18 compiled - ;; do it exactly like call-interactively, even if this - ;; means (interactive...) can come arbitrary late in FUN's body - (setq fint (assq 'interactive (cdr (cdr flambda)))) - (or fint - (error "Cannot get spec of a non-interactive command: %s!" fun)) - (nth 1 fint)) - (t ; otherwise it's a v19 compiled-code object - (aref flambda 5))))) - -(defun gmhist-symbol-function (fun) - ;; Return FUN's ultimate definition. - ;; Recurse if FUN is fset to another function's name. - (let ((flambda (symbol-function fun))) - (if (symbolp flambda) - ;; Prefer recursion over while because infinite loop is caught - ;; by max-lisp-eval-depth. - (gmhist-symbol-function flambda) - flambda))) - -;; Automagic gmhistification - -;; There should be a builtin split function - inverse to mapconcat. -(defun gmhist-split (pat str &optional limit) - "Splitting on regexp PAT, turn string STR into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list. -Thus, if SEP is a regexp that only matches itself, - - (mapconcat 'identity (gmhist-split SEP STRING) SEP) - -is always equal to STRING." - (let* ((start (string-match pat str)) - (result (list (substring str 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pat str end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring str end start) result) - end (match-end 0) - start end) - )) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring str end) result))) - (nreverse result))) - -(defun gmhist-interactive (spec hist) - "Interpret SPEC, an interactive string, like call-interactively -would, only with minibuffer history in HIST (a symbol). - -If the value of HIST is another symbol (which can never happen if -history lists are already stored on it), this symbol is taken instead -to facilitate dynamic indirections. - -Currently recognized key letters are: - - a b B c C d D k m N n s S x X f F r p P v - -and initial `*'. - -Use it inside interactive like this - - \(interactive \(gmhist-interactive \"sPrompt: \\nP\" 'foo-history\)\) - -or even like this: - - \(interactive - \(gmhist-interactive \"sReplace: \\nsReplace %s with: \" 'replace-history\)\) -" - (or (stringp spec) - (error "gmhist-interactive: not a string %s" spec)) - (if (and (> (length spec) 0) (eq ?\* (aref spec 0))) - (progn - (barf-if-buffer-read-only) - (setq spec (substring spec 1)))) - (if (and (boundp hist) - (symbolp (symbol-value hist)) - (not (null (symbol-value hist)))) - (setq hist (symbol-value hist))) - (let ((spec-list (mapcar '(lambda (x) - ;; forgive empty entries like - ;; call-interactively does: - (if (equal "" x) - nil - (cons (aref x 0) (substring x 1)))) - (gmhist-split "\n" spec))) - cur-arg args-so-far special elt char prompt xprompt) - (setq spec-list (delq nil spec-list)) - (while spec-list - (setq elt (car spec-list) - spec-list (cdr spec-list) - special nil ; special handling of args-so-far - char (car elt) - prompt (cdr elt) - xprompt (apply (function format) prompt (reverse args-so-far))) - (cond ((eq char ?a) ; Symbol defined as a function - (setq cur-arg (intern - (completing-read-with-history-in - hist xprompt obarray 'fboundp t nil)))) - ((eq char ?b) ; Name of existing buffer - (setq cur-arg (read-buffer-with-history-in - hist xprompt (other-buffer) t))) - ((eq char ?B) ; Name of possibly non-existing buffer - (setq cur-arg (read-buffer-with-history-in - hist xprompt (other-buffer) nil))) - ((eq char ?c) ; Character - (message xprompt) ; history doesn't make sense for this - (setq cur-arg (read-char))) - ((eq char ?C) ; Command - (setq cur-arg (intern - (completing-read-with-history-in - hist xprompt obarray 'commandp t nil)))) - ((eq char ?d) ; Value of point. Does not do I/O. - (setq cur-arg (point))) - ((eq char ?D) ; directory name - ;; This does not check file-directory-p, but neither does - ;; call-interactively. - (setq cur-arg (read-file-name-with-history-in - hist - xprompt - nil - default-directory - 'confirm))) - ((eq char ?f) ; existing file name - (setq cur-arg (read-file-name-with-history-in - hist - xprompt - nil nil 'confirm))) - ((eq char ?F) ; possibly nonexistent file name - (setq cur-arg (read-file-name-with-history-in - hist - xprompt))) - ((eq char ?k) ; Key sequence (string) - (setq cur-arg (read-key-sequence (if (equal xprompt "") - nil xprompt)))) - ((eq char ?m) ; Value of mark. Does not do I/O. - (setq cur-arg (or (mark) (error "The mark is not set now")))) - ((eq char ?N) ; Prefix arg, else number from minibuf - (if current-prefix-arg - (setq cur-arg (prefix-numeric-value current-prefix-arg)) - (while (not (integerp - (setq cur-arg - (read-with-history-in hist xprompt nil t))))))) - ((eq char ?n) ; Read number from minibuffer - (while (not (integerp - (setq cur-arg - (read-with-history-in hist xprompt nil t)))))) - ((eq char ?p) ; cooked prefix arg - (setq cur-arg (prefix-numeric-value current-prefix-arg))) - ((eq char ?P) ; raw prefix arg - (setq cur-arg current-prefix-arg)) - ((eq char ?r) ; region - (let (region-min region-max) - ;; take some pains to behave exactly like interactive "r" - (setq region-min (min (or (mark) - (error "The mark is not set now")) - (point)) - region-max (max (or (mark) - (error "The mark is not set now")) - (point))) - (setq args-so-far - (append (list region-max region-min) args-so-far) - special t))) - ((eq char '?s) ; string - (setq cur-arg (read-with-history-in hist xprompt))) - ((eq char ?S) ; any symbol - (setq cur-arg (read-with-history-in hist xprompt nil t))) - ((eq char ?v) ; Variable name - (setq cur-arg (completing-read-with-history-in - hist xprompt obarray 'user-variable-p t nil))) - ((memq char '(?x ?X)) ; lisp expression - (setq cur-arg (read-with-history-in - hist - xprompt - nil - ;; have to tell gmhist to read s-exps - ;; instead of strings: - t)) - (if (eq char ?X) ; lisp expression, evaluated - (setq cur-arg (eval cur-arg)))) - - (t - (error "Invalid control letter `%c' in gmhist-interactive" char))) - (or special - (setq args-so-far (cons cur-arg args-so-far)))) - (reverse args-so-far))) - -(defun gmhist-new-spec (fun &optional hist no-error) - "Return a new interactive specification for FUN, suitable for use -with setcdr in function gmhist-replace-spec. -Use symbol HIST to store the history. HIST defaults to `FUN-history'. -The returned spec does the same as the old one, only with history in HIST. - -If FUN is an autoload object, its file is loaded first. - -See function gmhist-interactive for a list of recognized interactive -keys letters. - -Unless optional third arg NO-ERROR is given, signals an error if FUN's -interactive string contains unknown key letters or has no interactive string. -With NO-ERROR, it returns nil." - (or hist (setq hist (intern (concat (symbol-name fun) "-history")))) - (gmhist-check-autoload fun) - (let ((spec (gmhist-spec fun))) - (if (stringp spec) - (list 'gmhist-interactive spec (list 'quote hist)) - (if no-error - nil - (error "Can't gmhistify %s's spec: %s" fun spec))))) - -(defun gmhist-make-magic (fun &optional hist) - "Make FUN magically maintain minibuffer history in symbol HIST. -HIST defaults to `FUN-history'. -This works by modifying the interactive specification, which must be a -string. For more complicated cases, see gmhist-replace-spec. -The magic goes away when you call gmhist-remove-magic on FUN." - (interactive "CPut gmhist magic on command: ") - (let ((new-spec (gmhist-new-spec fun hist t))) - (if new-spec - (gmhist-replace-spec fun new-spec) - ;; else there was some error. Try to find out if this is a retry. - (if (not (get fun 'gmhist-old-interactive-spec)) - (error "Too complicated for gmhist: %s" fun) - (message "Another attempt to put magic on %s..." fun) - (gmhist-remove-magic fun) ; will abort if not a retry - ;; This time we don't catch errors - magic or blow! - (gmhist-replace-spec fun (gmhist-new-spec fun hist)) - (message "Another attempt to put magic on %s...done." fun))))) - -(defun gmhist-remove-magic (fun) - "Remove the magic that gmhist-make-magic put on FUN, -restoring the old interactive spec." - (interactive "CRemove gmhist magic from command: ") - (gmhist-replace-spec - fun - (or (get fun 'gmhist-old-interactive-spec) - (error "Can't find %s's old interactive spec!" fun)))) - -;; Now make yourself magic -(gmhist-make-magic 'gmhist-make-magic 'gmhist-make-magic-history) -(gmhist-make-magic 'gmhist-remove-magic 'gmhist-make-magic-history) - - -;; Examples, pedagogic and serious ones. More in gmhist-app.el. - -;;(defun foo-command (cmd) -;; (interactive (list -;; (read-with-history-in 'foo-history "Foo: "))) -;; (message "Foo %s" cmd)) -;; -;; ;; The interactive clause could also have been the simpler -;; ;; (interactive (gmhist-interactive "sFoo: " 'foo-history)) -;; -;; -;;;(put 'foo-history 'hist-map minibuffer-local-map) ; disable motion ... -;;;(put 'foo-history 'hist-function 'gmhist-read-nohistory) ; and history -;; -;;(put 'foo-history 'hist-function nil) ; enable history ... -;;(put 'foo-history 'hist-map nil) ; and motion again -;; -;;(defun gmhist-read-nohistory (symbol prompt initial-input read) -;; "An example function to put on the hist-function property." -;; (message "read-nohistory...") -;; (sit-for 2) -;; (read-string prompt initial-input)) -;; -;; Example for reading file names: -;;(defun bar-command (cmd) -;; (interactive -;; (list -;; (read-file-name-with-history-in -;; ;; HIST-SYM PROMPT DIR DFLT MUSTMATCH -;; 'bar-history "Bar: " nil nil 'confirm))) -;; (message "Bar %s" cmd)) -;; -;; Example function to apply gmhist-make-magic to. -;; Compare the missing initial input in bar to the magic version of zod. -;;(defun zod-command (cmd) -;; (interactive "fZod: ") -;; (message "Zod %s" cmd)) - -;; Finally run the load-hook - -(run-hooks 'gmhist-load-hook) - -;; End of file gmhist.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/Makefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/Makefile Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,244 @@ +############################################################################### +# +# File: Makefile +# Release: $efs release: 1.15 $ +# Version: $Revision: 1.2 $ +# RCS: +# Description: Makefile for byte-compiling efs and dired. +# Author: Andy Norman, HPLabs, Bristol, UK. +# Created: Sat Jan 30 00:18:56 1993 +# Language: Text (make script) +# +############################################################################### + +## Installation Instructions +############################ +# 1. Edit the configuration variables below. +# EMACS should be the name of the emacs program on your system. +# VERSION should be the emacs version. This must be one of: +# 18 for all versions of Emacs 18. +# 19 for all versions of the original GNU Emacs from FSF between +# 19.1 and 19.22, inclusive. +# 19.23 for version 19.23 and later of the original GNU Emacs from FSF +# l19.11 for XEmacs 19.11 trhu 19.14 +# x19.15 for XEmacs 19.15 and later +# LISPDIR should be the directory in which you want the .elc +# files installed. +# BDIR should be the directory containing the .elc files for the +# byte-compiler. Although efs byte-compiles and works with the +# Emacs V18 byte-compiler, it is strongly recommended to use +# Jamie Zawinski's V19 byte-compiler. This byte-compiler is +# standard with Lucid Emacs, XEmacs, and GNU Emacs V19, so in this +# case you can set BDIR to nothing. +# VMDIR should be set to the directory containing the .elc files for +# VM. If you aren't using VM, then set this to nothing. +# +# 2. To byte-compile the entire package, except for VM support (efs-vm.el), +# run make VERSION, where VERSION is the emacs version that you are +# compiling for. It must be one of: +# 18 for Emacs 18 +# 19 for the original GNU Emacs from FSF, versions 19.1 through +# 19.22, inclusive +# 19.23 for the original GNU Emacs from FSF, version 19.23 and later. +# l19.11 for Lucid XEmacs 19.11 thru 19.14 +# x19.15 for XEmacs 19.15 and later +# +# If you have set the VERSION variable correctly, then typing just +# make will suffice. +# +# 3. To byte-compile everything, including VM support, run make all. +# +# 4. To byte-compile all the efs files, except for VM support, +# run make efs. +# +# 5. To byte-compile only the core efs files run make core. +# +# 6. To byte compile an efs-XXX.el file, run make XXX. +# This means that VM support can be compiled by running make vm. +# +# 7. To byte compile only dired, run make dired. +# +# 8. To byte-compile only efs-auto.el, for autoloading efs, run make auto. +# + +## Edit these variables according to your configuration. + +# Name of Emacs program +EMACS=xemacs +# Emacs version. This must be set to one of 18, 19, 19.23, +# l19.11, x19.15 +VERSION=x19.15 +# Current working directory +CWD=`pwd` +# Directory in which to install the lisp files +LISPDIR= +# Directory containing byte-compiler. This is used by fixup.el +BDIR= +# Directory containing VM's .elc files. +VMDIR= +# Bourne shell executable, please. +SHELL=/bin/sh + +###### It should not be necessary to edit anything below this line. ###### + +COREOBJS = efs-defun.elc efs-ovwrt.elc efs-fnh.elc efs-cu.elc efs-netrc.elc \ + efs.elc efs-dired.elc efs-report.elc \ + efs-cp-p.elc auto-save.elc +DOBJS = default-dir.elc dired.elc dired-mob.elc dired-oas.elc \ + dired-rgxp.elc dired-shell.elc dired-vir.elc dired-xy.elc \ + dired-grep.elc dired-uu.elc \ + dired-cmpr.elc dired-diff.elc dired-help.elc dired-sex.elc +EFSOBJS = $(COREOBJS) efs-auto.elc \ + efs-cms.elc efs-cms-knet.elc efs-dos-distinct.elc efs-nos-ve.elc \ + efs-gwp.elc efs-kerberos.elc efs-hell.elc efs-ka9q.elc \ + efs-mpe.elc efs-mts.elc efs-mvs.elc efs-netware.elc \ + efs-pc.elc efs-ti-explorer.elc efs-ti-twenex.elc \ + efs-tops-20.elc efs-dl.elc efs-guardian.elc efs-coke.elc \ + efs-vms.elc efs-vos.elc efs-plan9.elc efs-ms-unix.elc +VMOBJS = efs-vm.elc +GEOBJS = dired-fsf.elc dired-mule.elc efs-dired-mule.elc +XEOBJS = dired-xemacs.elc +OBJS = $(DOBJS) $(EFSOBJS) $(VMOBJS) $(GEOBJS) $(XEOBJS) \ + efs-l19.11.elc efs-x19.15.elc \ + emacs-19.elc fn-handler.elc + +# fixup.el is never byte-compiled. It would do no harm, but be a waste +# of time. + +## Specify new rules. + +.SUFFIXES: .elc .el .texi .info + +.el.elc: + BDIR=$(BDIR) CWD=$(CWD) VMDIR=$(VMDIR) \ + $(EMACS) -batch -l $(CWD)/fixup -f batch-byte-compile $(CWD)/$< + +.texi.info: + $(EMACS) -batch -f batch-texinfo-format $(CWD)/$< + +## targets + +# What lazy fingers buys you +default: $(VERSION) dired + +# .elc files depend on .el source +# Do this in this brain-dead way because different makes do pattern +# rules differently. grumble grumble... +# +# dired +dired.elc: dired.el +dired-mob.elc: dired-mob.el +dired-oas.elc: dired-oas.el +dired-rgxp.elc: dired-rgxp.el +dired-shell.elc: dired-shell.el +dired-vir.elc: dired-vir.el +dired-xy.elc: dired-xy.el +dired-grep.elc: dired-grep.el +dired-uu.elc: dired-uu.el +dired-fsf.elc: dired-fsf.el +dired-cmpr.elc: dired-cmpr.el +dired-help.elc: dired-help.el +dired-diff.elc: dired-diff.el +dired-sex.elc: dired-sex.el +dired-mule.elc: dired-mule.el +dired-xemacs.elc: dired-xemacs.el +default-dir.elc: default-dir.el +# efs core files +efs.elc: efs.el +efs-defun.elc: efs-defun.el +efs-cp-p.elc: efs-cp-p.el +efs-cu.elc: efs-cu.el +efs-netrc.elc: efs-netrc.el +efs-auto.elc: efs-auto.el +efs-dired.elc: efs-dired.el +efs-dired-mule.elc: efs-dired-mule.el +efs-report.elc: efs-report.el +efs-ovwrt.elc: efs-ovwrt.el +efs-fnh.elc: efs-fnh.el +# efs multi-OS and FTP server support +efs-cms.elc: efs-cms.el +efs-cms-knet.elc: efs-cms-knet.el +efs-coke.elc: efs-coke.el +efs-dos-distinct.elc: efs-dos-distinct.el +efs-nos-ve.elc: efs-nos-ve.el +efs-gwp.elc: efs-gwp.el +efs-hell.elc: efs-hell.el +efs-ka9q.elc: efs-ka9q.el +efs-kerberos.elc: efs-kerberos.el +efs-mpe.elc: efs-mpe.el +efs-mts.elc: efs-mts.el +efs-mvs.elc: efs-mvs.el +efs-netware.elc: efs-netware.el +efs-pc.elc: efs-pc.el +efs-ti-explorer.elc: efs-ti-explorer.el +efs-ti-twenex.elc: efs-ti-twenex.el +efs-tops-20.elc: efs-tops-20.el +efs-dl.elc: efs-dl.el +efs-vms.elc: efs-vms.el +efs-vos.elc: efs-vos.el +efs-guardian.elc: efs-guardian.el +efs-plan9.elc: efs-plan9.el +efs-ms-unix.elc: efs-ms-unix.el +# efs support for different Emacs versions +efs-l19.11.elc: efs-l19.11.el +efs-x19.15.elc: efs-x19.15.el +# efs vm support +efs-vm.elc: efs-vm.el +# backward compatibility files +fn-handler.elc: fn-handler.el +emacs-19.elc: emacs-19.el +# auto-save package +auto-save.elc: auto-save.el + +# Core targets +core: $(COREOBJS) + +# Extra perks +auto: core efs-auto.elc +cms: core efs-cms.elc +cms-knet: core efs-cms-knet.elc +dos-distinct: core efs-dos-distinct.elc +nos-ve: core efs-nos-ve.elc +gwp: core efs-gwp.elc +hell: core efs-hell.elc +ka9q: core efs-ka9q.elc +kerberos: core efs-kerberos.elc +mpe: core efs-mpe.elc +mts: core efs-mts.elc +mvs: core efs-mvs.elc +netware: core efs-netware.elc +pc: core efs-pc.elc +ti-explorer: core efs-ti-explorer.elc +ti-twenex: core efs-ti-twenex.elc +tops-20: core efs-tops-20.elc +dl: core efs-dl.elc +vms: core efs-vms.elc +vos: core efs-vos.elc +guardian: core efs-guardian.elc +plan9: core efs-plan9.elc +coke: core efs-coke.elc +vm: core $(VMOBJS) + +# The grand tour +efs: $(EFSOBJS) +dired: $(DOBJS) +all: $(OBJS) + +# Making for a specific emacs version +l19.11: efs dired efs-l19.11.elc $(XEOBJS) +x19.15: efs dired efs-x19.15.elc $(XEOBJS) + +# Installation +install: + @echo "Installing in $(LISPDIR)..." + @ls -C *.elc + cp *.elc $(LISPDIR) +install_src: + @echo "Installing in $(LISPDIR)..." + @ls -C `ls *.el 2>&1 | grep -v "fixup"` 2> /dev/null + cp `ls *.el | grep -v "fixup"` $(LISPDIR) +install_all: install_src install +clean: + rm -f $(OBJS) + +## end of Makefile ## diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/auto-save.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/auto-save.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,513 @@ +;; -*- Emacs-Lisp -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: auto-save.el +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Safer autosaving with support for efs and /tmp. +;; This version of auto-save is designed to work with efs, +;; instead of ange-ftp. +;; Author: Sebastian Kremer , +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst auto-save-version (substring "$Revision: 1.2 $" 11 -2) + "Version number of auto-save.") + +;;; Copyright (C) 1992 by Sebastian Kremer + +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. + +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. + +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; OVERVIEW ========================================================== + +;;; Combines autosaving for efs (to a local or remote directory) +;;; with the ability to do autosaves to a fixed directory on a local +;;; disk, in case NFS is slow. The auto-save file used for +;;; /usr/foo/bar/baz.txt +;;; will be +;;; AUTOSAVE/#\!usr\!foo\!bar\!baz.txt# +;;; assuming AUTOSAVE is the non-nil value of the variable +;;; `auto-save-directory'. + +;;; Takes care that autosave files for non-file-buffers (e.g. *mail*) +;;; from two simultaneous Emacses don't collide. + +;;; Autosaves even if the current directory is not writable. + +;;; Can limit autosave names to 14 characters using a hash function, +;;; see `auto-save-hash-p'. + +;;; See `auto-save-directory' and `make-auto-save-file-name' and +;;; references therein for complete documentation. + +;;; Meta-x recover-all-files will effectively do recover-file on all +;;; files whose autosave file is newer (one of the benefits of having +;;; all autosave files in the same place). + +;;;; INSTALLATION ====================================================== + +;;; Put this file into your load-path and the following in your ~/.emacs: + +;;; If you want to autosave in the fixed directory /tmp/USER-autosave/ +;;; (setq auto-save-directory +;;; (concat "/tmp/" (user-login-name) "-autosave/")) + +;;; If you don't want to save in /tmp (e.g., because it is swap +;;; mounted) but rather in ~/autosave/ +;;; (setq auto-save-directory (expand-file-name "~/autosave/")) + +;;; If you want to save each file in its own directory (the default) +;;; (setq auto-save-directory nil) +;;; You still can take advantage of autosaving efs remote files +;;; in a fixed local directory, `auto-save-directory-fallback' will +;;; be used. + +;;; If you want to use 14 character hashed autosave filenames +;;; (setq auto-save-hash-p t) + +;;; Finally, put this line after the others in your ~/.emacs: +;;; (require 'auto-save) + + +;;;; ACKNOWLEDGEMENT =================================================== + +;;; This code is loosely derived from autosave-in-tmp.el by Jamie +;;; Zawinski (the version I had was last modified 22 +;;; dec 90 jwz) and code submitted to ange-ftp-lovers on Sun, 5 Apr +;;; 92 23:20:47 EDT by drw@BOURBAKI.MIT.EDU (Dale R. Worley). +;;; auto-save.el tries to cover the functionality of those two +;;; packages. + +;;; Valuable comments and help from Dale Worley, Andy Norman, Jamie +;;; Zawinski and Sandy Rutherford are gratefully acknowledged. + +;;;; PROVISION ======================================================== + +(provide 'auto-save) + +;;;; CUSTOMIZATION ===================================================== + +(defvar auto-save-directory nil + + ;;; Don't make this user-variable-p, it should be set in .emacs and + ;;; left at that. In particular, it should remain constant across + ;;; several Emacs session to make recover-all-files work. + + "If non-nil, fixed directory for autosaving: all autosave files go +there. If this directory does not yet exist at load time, it is +created and its mode is set to 0700 so that nobody else can read your +autosave files. + +If nil, each autosave files goes into the same directory as its +corresponding visited file. + +A non-nil `auto-save-directory' could be on a local disk such as in +/tmp, then auto-saves will always be fast, even if NFS or the +automounter is slow. In the usual case of /tmp being locally mounted, +note that if you run emacs on two different machines, they will not +see each other's auto-save files. + +The value \(expand-file-name \"~/autosave/\"\) might be better if /tmp +is mounted from swap (possible in SunOS, type `df /tmp' to find out) +and thus vanishes after a reboot, or if your system is particularly +thorough when cleaning up /tmp, clearing even non-empty subdirectories. + +It should never be an efs remote filename because that would +defeat `efs-auto-save-remotely'. + +Unless you set `auto-save-hash-p', you shouldn't set this to a +directory in a filesystem that does not support long filenames, since +a file named + + /home/sk/lib/emacs/lisp/auto-save.el + +will have a longish filename like + + AUTO-SAVE-DIRECTORY/#\\!home\\!sk\\!lib\\!emacs\\!lisp\\!auto-save.el# + +as auto save file. + +See also variables `auto-save-directory-fallback', +`efs-auto-save' and `efs-auto-save-remotely'.") + +(defvar auto-save-hash-p nil + "If non-nil, hashed autosave names of length 14 are used. +This is to avoid autosave filenames longer than 14 characters. +The directory used is `auto-save-hash-directory' regardless of +`auto-save-directory'. +Hashing defeats `recover-all-files', you have to recover files +individually by doing `recover-file'.") + +;;; This defvar is in efs.el now, but doesn't hurt to give it here as +;;; well so that loading first auto-save.el does not abort. +(or (boundp 'efs-auto-save) (defvar efs-auto-save 0)) +(or (boundp 'efs-auto-save-remotely) (defvar efs-auto-save-remotely nil)) + +(defvar auto-save-offer-delete nil + "*If non-nil, `recover-all-files' offers to delete autosave files +that are out of date or were dismissed for recovering. +Special value 'always deletes those files silently.") + +;;;; end of customization + + +;;; Preparations to be done at load time + +(defvar auto-save-directory-fallback (expand-file-name "~/autosave/") + ;; not user-variable-p, see above + "Directory used for local autosaving of remote files if +both `auto-save-directory' and `efs-auto-save-remotely' are nil. +Also used if a working directory to be used for autosaving is not writable. +This *must* always be the name of directory that exists or can be +created by you, never nil.") + +(defvar auto-save-hash-directory + (expand-file-name "hash/" (or auto-save-directory + auto-save-directory-fallback)) + "If non-nil, directory used for hashed autosave filenames.") + +(defun auto-save-check-directory (var) + (let ((dir (symbol-value var))) + (if (null dir) + nil + ;; Expand and store back into the variable + (set var (setq dir (expand-file-name dir))) + ;; Make sure directory exists + (if (file-directory-p dir) + nil + ;; Else we create and chmod 0700 the directory + (setq dir (directory-file-name dir)) ; some systems need this + (if (fboundp 'make-directory) ; V19 or tree dired + (make-directory dir) + (call-process "mkdir" nil nil nil dir)) + (set-file-modes dir (* 7 8 8)))))) + +(mapcar (function auto-save-check-directory) + '(auto-save-directory auto-save-directory-fallback)) + +(and auto-save-hash-p + (auto-save-check-directory 'auto-save-hash-directory)) + + +;;; Computing an autosave name for a file and vice versa + +(defun make-auto-save-file-name ();; redefines files.el + ;; auto-save-file-name-p need not be redefined. + + "Return file name to use for auto-saves of current buffer. +Does not consider `auto-save-visited-file-name'; that is checked +before calling this function. + +Offers to autosave all files in the same `auto-save-directory'. All +autosave files can then be recovered at once with function +`recover-all-files'. + +Takes care to make autosave files for files accessed through efs +be local files if variable `efs-auto-save-remotely' is nil. + +Takes care of slashes in buffer names to prevent autosave errors. + +Takes care that autosave files for buffers not visiting any file (such +as `*mail*') from two simultaneous Emacses don't collide by prepending +the Emacs pid. + +Uses 14 character autosave names if `auto-save-hash-p' is true. + +Autosaves even if the current directory is not writable, using +directory `auto-save-directory-fallback'. + +You can redefine this for customization (he he :-). +See also function `auto-save-file-name-p'." + + ;; We have to be very careful about not signalling an error in this + ;; function since files.el does not provide for this (e.g. find-file + ;; would fail for each new file). + + (condition-case error-data + (let* ((file-name (or (and (boundp 'buffer-file-truename) + buffer-file-truename + ;; Make sure that the file name is expanded. + (expand-file-name buffer-file-name)) + (and buffer-file-name + (expand-file-name buffer-file-name)))) + ;; So autosavename looks like #%...#, roughly as with the + ;; old make-auto-save-file-name function. The + ;; make-temp-name inserts the pid of this Emacs: this + ;; avoids autosaving from two Emacses into the same file. + ;; It cannot be recovered automatically then because in + ;; the next Emacs session (the one after the crash) the + ;; pid will be different, but file-less buffers like + ;; *mail* must be recovered manually anyway. + (name-prefix (if file-name nil (make-temp-name "#%"))) + (save-name (or file-name + ;; Prevent autosave errors. Buffername + ;; (to become non-dir part of filename) will + ;; be unslashified twice. Don't care. + (auto-save-unslashify-name (buffer-name)))) + (remote-p (and (stringp file-name) + (fboundp 'efs-ftp-path) + (efs-ftp-path file-name)))) + ;; Return the appropriate auto save file name: + (expand-file-name;; a buffername needs this, a filename not + (if remote-p + (if efs-auto-save-remotely + (auto-save-name-in-same-directory save-name) + ;; We have to use the `fixed-directory' now since the + ;; `same-directory' would be remote. + ;; It will use the fallback if needed. + (auto-save-name-in-fixed-directory save-name)) + ;; Else it is a local file (or a buffer without a file, hence + ;; the name-prefix). + ;; Hashed files always go into the special hash dir, never + ;; in the same directory, to make recognizing reliable. + (if (or auto-save-directory auto-save-hash-p) + (auto-save-name-in-fixed-directory save-name name-prefix) + (auto-save-name-in-same-directory save-name name-prefix))))) + + ;; If any error occurs in the above code, return what the old + ;; version of this function would have done. It is not ok to + ;; return nil, e.g., when after-find-file tests + ;; file-newer-than-file-p, nil would bomb. + + (error (progn + (message "make-auto-save-file-name %s" error-data) + (sit-for 2) + (if buffer-file-name + (concat (file-name-directory buffer-file-name) + "#" + (file-name-nondirectory buffer-file-name) + "#") + (expand-file-name (concat "#%" (buffer-name) "#"))))))) + +(defun auto-save-original-name (savename) + "Reverse of `make-auto-save-file-name'. +Returns nil if SAVENAME was not associated with a file (e.g., it came +from an autosaved `*mail*' buffer) or does not appear to be an +autosave file at all. +Hashed files are not understood, see `auto-save-hash-p'." + (let ((basename (file-name-nondirectory savename)) + (savedir (file-name-directory savename))) + (cond ((or (not (auto-save-file-name-p basename)) + (string-match "^#%" basename)) + nil) + ;; now we know it looks like #...# thus substring is safe to use + ((or (equal savedir auto-save-directory) ; 2nd arg may be nil + (equal savedir auto-save-directory-fallback)) + ;; it is of the `-fixed-directory' type + (auto-save-slashify-name (substring basename 1 -1))) + (t + ;; else it is of `-same-directory' type + (concat savedir (substring basename 1 -1)))))) + +(defun auto-save-name-in-fixed-directory (filename &optional prefix) + ;; Unslashify and enclose the whole FILENAME in `#' to make an auto + ;; save file in the auto-save-directory, or if that is nil, in + ;; auto-save-directory-fallback (which must be the name of an + ;; existing directory). If the results would be too long for 14 + ;; character filenames, and `auto-save-hash-p' is set, hash FILENAME + ;; into a shorter name. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((base-name (concat (or prefix "#") + (auto-save-unslashify-name filename) + "#"))) + (if (and auto-save-hash-p + auto-save-hash-directory + (> (length base-name) 14)) + (expand-file-name (auto-save-cyclic-hash-14 filename) + auto-save-hash-directory) + (expand-file-name base-name + (or auto-save-directory + auto-save-directory-fallback))))) + +(defun auto-save-name-in-same-directory (filename &optional prefix) + ;; Enclose the non-directory part of FILENAME in `#' to make an auto + ;; save file in the same directory as FILENAME. But if this + ;; directory is not writable, use auto-save-directory-fallback. + ;; FILENAME is assumed to be in non-directory form (no trailing slash). + ;; It may be a name without a directory part (pesumably it really + ;; comes from a buffer name then), the fallback is used then. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((directory (file-name-directory filename))) + (or (null directory) + (file-writable-p directory) + (setq directory auto-save-directory-fallback)) + (concat directory ; (concat nil) is "" + (or prefix "#") + (file-name-nondirectory filename) + "#"))) + +(defun auto-save-unslashify-name (s) + ;; "Quote any slashes in string S by replacing them with the two + ;;characters `\\!'. + ;;Also, replace any backslash by double backslash, to make it one-to-one." + (let ((limit 0)) + (while (string-match "[/\\]" s limit) + (setq s (concat (substring s 0 (match-beginning 0)) + (if (string= (substring s + (match-beginning 0) + (match-end 0)) + "/") + "\\!" + "\\\\") + (substring s (match-end 0)))) + (setq limit (1+ (match-end 0))))) + s) + +(defun auto-save-slashify-name (s) + ;;"Reverse of `auto-save-unslashify-name'." + (let (pos) + (while (setq pos (string-match "\\\\[\\!]" s pos)) + (setq s (concat (substring s 0 pos) + (if (eq ?! (aref s (1+ pos))) "/" "\\") + (substring s (+ pos 2))) + pos (1+ pos)))) + s) + + +;;; Hashing for autosave names + +;;; Hashing function contributed by Andy Norman +;;; based upon C code from pot@fly.cnuce.cnr.IT (Francesco Potorti`). + +(defun auto-save-cyclic-hash-14 (s) + ;; "Hash string S into a string of length 14. + ;; A 7-bytes cyclic code for burst correction is calculated on a + ;; byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1. + ;; The resulting string consists of hexadecimal digits [0-9a-f]. + ;; In particular, it contains no slash, so it can be used as autosave name." + (let ((crc (make-string 7 0)) + result) + (mapcar + (function + (lambda (new) + (setq new (+ new (aref crc 6))) + (aset crc 6 (+ (aref crc 5) new)) + (aset crc 5 (aref crc 4)) + (aset crc 4 (aref crc 3)) + (aset crc 3 (+ (aref crc 2) new)) + (aset crc 2 (aref crc 1)) + (aset crc 1 (aref crc 0)) + (aset crc 0 new))) + s) + (setq result (format "%02x%02x%02x%02x%02x%02x%02x" + (aref crc 0) + (aref crc 1) + (aref crc 2) + (aref crc 3) + (aref crc 4) + (aref crc 5) + (aref crc 6))) + result)) + +;; This leaves two characters that could be used to wrap it in `#' or +;; make two filenames from it: one for autosaving, and another for a +;; file containing the name of the autosaved filed, to make hashing +;; reversible. +(defun auto-save-cyclic-hash-12 (s) + "Outputs the 12-characters ascii hex representation of a 6-bytes +cyclic code for burst correction calculated on STRING on a +byte-by-byte basis. The used polynomial is D^6 + D^5 + D^4 + D^3 +1." + (let ((crc (make-string 6 0))) + (mapcar + (function + (lambda (new) + (setq new (+ new (aref crc 5))) + (aset crc 5 (+ (aref crc 4) new)) + (aset crc 4 (+ (aref crc 3) new)) + (aset crc 3 (+ (aref crc 2) new)) + (aset crc 2 (aref crc 1)) + (aset crc 1 (aref crc 0)) + (aset crc 0 new))) + s) + (format "%02x%02x%02x%02x%02x%02x" + (aref crc 0) + (aref crc 1) + (aref crc 2) + (aref crc 3) + (aref crc 4) + (aref crc 5)))) + + + +;;; Recovering files + +(defun recover-all-files (&optional silent) + "Do recover-file for all autosave files which are current. +Only works if you have a non-nil `auto-save-directory'. + +Optional prefix argument SILENT means to be silent about non-current +autosave files. This is useful if invoked automatically at Emacs +startup. + +If `auto-save-offer-delete' is t, this function will offer to delete +old or rejected autosave files. + +Hashed files (see `auto-save-hash-p') are not understood, use +`recover-file' to recover them individually." + (interactive "P") + (let ((savefiles (directory-files auto-save-directory t "^#")) + afile ; the auto save file + file ; its original file + (total 0) ; # of files offered to recover + (count 0)) ; # of files actually recovered + (or (equal auto-save-directory auto-save-directory-fallback) + (setq savefiles + (append savefiles + (directory-files auto-save-directory-fallback t "^#")))) + (while savefiles + (setq afile (car savefiles) + file (auto-save-original-name afile) + savefiles (cdr savefiles)) + (cond ((and file (not (file-newer-than-file-p afile file))) + (message "autosave file \"%s\" is not current." afile) + (sit-for 2)) + (t + (setq total (1+ total)) + (with-output-to-temp-buffer "*Directory*" + (call-process "ls" nil standard-output nil + "-l" afile (if file (list file)))) + (if (yes-or-no-p (format "Recover %s from auto save file? " + file)) + (let* ((obuf (current-buffer)) + (buf (set-buffer + (if file + (find-file-noselect file t) + (generate-new-buffer "*recovered*")))) + (buffer-read-only nil)) + (erase-buffer) + (insert-file-contents afile nil) + (condition-case () + (after-find-file nil) + (error nil)) + (setq buffer-auto-save-file-name nil) + (setq count (1+ count)) + (message "\ +Auto-save off in buffer \"%s\" till you do M-x auto-save-mode." + (buffer-name)) + (set-buffer obuf) + (sit-for 1)) + ;; If not used for recovering, offer to delete + ;; autosave file + (and auto-save-offer-delete + (or (eq 'always auto-save-offer-delete) + (yes-or-no-p + (format "Delete autosave file for `%s'? " file))) + (delete-file afile)))))) + (if (zerop total) + (or silent (message "Nothing to recover.")) + (message "%d/%d file%s recovered." count total (if (= count 1) "" "s")))) + (if (get-buffer "*Directory*") (kill-buffer "*Directory*"))) + +;;; end of auto-save.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/default-dir.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/default-dir.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,346 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: default-dir.el +;; RCS: +;; Version: $Revision: 1.2 $ +;; Description: Defines the function default-directory, for fancy handling +;; of the initial contents in the minibuffer when reading +;; file names. +;; Authors: Sebastian Kremer +;; Sandy Rutherford +;; Created: Sun Jul 18 11:38:06 1993 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +(provide 'default-dir) +(require 'efs-ovwrt) + +(defconst default-dir-emacs-variant + (cond ((string-match "XEmacs" emacs-version) 'xemacs) + ((>= (string-to-int (substring emacs-version 0 2)) 19) 'fsf-19) + (t 'fsf-18))) + +;;;###autoload +(defvar default-directory-function nil + "A function to call to compute the default-directory for the current buffer. +If this is nil, the function default-directory will return the value of the +variable default-directory. +Buffer local.") +(make-variable-buffer-local 'default-directory-function) + +;; As a bonus we give shell-command history if possible. +(defvar shell-command-history nil + "History list of previous shell commands.") + +(defun default-directory () + " Returns the default-directory for the current buffer. +Will use the variable default-directory-function if it non-nil." + (if default-directory-function + (funcall default-directory-function) + (if (eq default-dir-emacs-variant 'xemacs) + (abbreviate-file-name default-directory t) + (abbreviate-file-name default-directory)))) + +;;; Overloads + +(if (or (featurep 'mule) + (boundp 'MULE)) + (progn + + (defun default-dir-find-file (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file: " (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file file coding-system)) + + (defun default-dir-find-file-other-window (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other window: " (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-other-window file coding-system)) + + (defun default-dir-find-file-read-only (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only: " (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only file coding-system)) + + (if (fboundp 'find-file-read-only-other-window) + (progn + (defun default-dir-find-file-read-only-other-window + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name + "Find file read-only in other window: " + (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only-other-window file + coding-system)))) + + (if (fboundp 'find-file-other-frame) + (progn + (defun default-dir-find-file-other-frame + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other frame: " + (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-other-frame file + coding-system)))) + + (if (fboundp 'find-file-read-only-other-frame) + (progn + (defun default-dir-find-file-read-only-other-frame + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only in other frame: " + (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only-other-frame file + coding-system))))) + + (defun default-dir-find-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file: " (default-directory))))) + (default-dir-real-find-file file)) + + (defun default-dir-find-file-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other window: " (default-directory))))) + (default-dir-real-find-file-other-window file)) + + (defun default-dir-find-file-read-only (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only: " (default-directory) nil t)))) + (default-dir-real-find-file-read-only file)) + + (if (fboundp 'find-file-read-only-other-window) + (progn + (defun default-dir-find-file-read-only-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name + "Find file read-only in other window: " + (default-directory) nil t)))) + (default-dir-real-find-file-read-only-other-window file)))) + + (if (fboundp 'find-file-other-frame) + (progn + (defun default-dir-find-file-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other frame: " + (default-directory))))) + (default-dir-real-find-file-other-frame file)))) + + (if (fboundp 'find-file-read-only-other-frame) + (progn + (defun default-dir-find-file-read-only-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only in other frame: " + (default-directory) nil t)))) + (default-dir-real-find-file-read-only-other-frame file))))) + +(efs-overwrite-fn "default-dir" 'find-file 'default-dir-find-file) +(efs-overwrite-fn "default-dir" 'find-file-other-window + 'default-dir-find-file-other-window) +(if (fboundp 'find-file-other-frame) + (efs-overwrite-fn "default-dir" 'find-file-other-frame + 'default-dir-find-file-other-frame)) +(efs-overwrite-fn "default-dir" 'find-file-read-only + 'default-dir-find-file-read-only) +(if (fboundp 'find-file-read-only-other-window) + (efs-overwrite-fn "default-dir" 'find-file-read-only-other-window + 'default-dir-find-file-read-only-other-window)) +(if (fboundp 'find-file-read-only-other-frame) + (efs-overwrite-fn "default-dir" 'find-file-read-only-other-frame + 'default-dir-find-file-read-only-other-frame)) + + +(defun default-dir-load-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Load file: " (default-directory) nil t)))) + (default-dir-real-load-file file)) + +(efs-overwrite-fn "default-dir" 'load-file 'default-dir-load-file) + +(require 'view) + +(defun default-dir-view-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file: " (default-directory) nil t)))) + (default-dir-real-view-file file)) + +(efs-overwrite-fn "default-dir" 'view-file 'default-dir-view-file) + +(if (fboundp 'view-file-other-window) + (progn + (defun default-dir-view-file-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file in other window: " + (default-directory) nil t)))) + (default-dir-real-view-file-other-window file)) + (efs-overwrite-fn "default-dir" 'view-file-other-window + 'default-dir-view-file-other-window))) + +(if (fboundp 'view-file-other-frame) + (progn + (defun default-dir-view-file-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file in other frame: " + (default-directory) nil t)))) + (default-dir-real-view-file-other-frame file)) + (efs-overwrite-fn "default-dir" 'view-file-other-frame + 'default-dir-view-file-other-frame))) + + +(defun default-dir-shell-command (command &optional insert) + "Documented as original" + (interactive + (list + (let ((prompt (format "Shell command in %s: " (default-directory)))) + (cond + ((memq default-dir-emacs-variant '(fsf-19 xemacs)) + (read-from-minibuffer prompt nil nil nil + 'shell-command-history)) + ((featurep 'gmhist) + (let ((minibuffer-history-symbol 'shell-command-history)) + (read-string prompt))) + (t (read-string prompt)))) + current-prefix-arg)) + (let ((default-directory (expand-file-name (default-directory)))) + (default-dir-real-shell-command command insert))) + +(efs-overwrite-fn "default-dir" 'shell-command 'default-dir-shell-command) + +;; Is advice about? +(if (featurep 'advice) + (defadvice cd (before default-dir-cd activate compile) + (interactive + (list + (expand-file-name + (read-file-name "Change default directory: " (default-directory)))))) + + (defun default-dir-cd (dir) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Change default directory: " (default-directory))))) + (default-dir-real-cd dir)) + + (efs-overwrite-fn "default-dir" 'cd 'default-dir-cd)) + +(defun default-dir-set-visited-file-name (filename) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Set visited file name: " (default-directory))))) + (default-dir-real-set-visited-file-name filename)) + +(efs-overwrite-fn "default-dir" 'set-visited-file-name + 'default-dir-set-visited-file-name) + +(defun default-dir-insert-file (filename &rest args) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Insert file: " (default-directory) nil t)))) + (apply 'default-dir-real-insert-file filename args)) + +(efs-overwrite-fn "default-dir" 'insert-file 'default-dir-insert-file) + +(defun default-dir-append-to-file (start end filename &rest args) + "Documented as original" + (interactive + (progn + (or (mark) (error "The mark is not set now")) + (list + (min (mark) (point)) + (max (mark) (point)) + (expand-file-name + (read-file-name "Append to file: " (default-directory)))))) + (apply 'default-dir-real-append-to-file start end filename args)) + +(efs-overwrite-fn "default-dir" 'append-to-file 'default-dir-append-to-file) + +(defun default-dir-delete-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Delete file: " (default-directory) nil t)))) + (default-dir-real-delete-file file)) + +(efs-overwrite-fn "default-dir" 'delete-file 'default-dir-delete-file) + +;;; end of default-dir.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-cmpr.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-cmpr.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,315 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-cmpr.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for compressing marked files. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-cmpr) +(require 'dired) + +;;; Entry points. + +(defun dired-do-compress (&optional arg files) + "Compress or uncompress marked (or next ARG) files. +With a zero prefix, prompts for a new value of `dired-compression-method'." + (interactive + (let ((arg (prefix-numeric-value current-prefix-arg)) + files) + (if (zerop arg) + (let ((new (completing-read + (format "Set compression method (currently %s): " + dired-compression-method) + (mapcar + (function + (lambda (x) + (cons (symbol-name (car x)) nil))) + dired-compression-method-alist) + nil t))) + (or (string-equal new "") + (setq dired-compression-method (intern new)))) + (setq files (dired-get-marked-files nil current-prefix-arg)) + (or (memq 'compress dired-no-confirm) + (let* ((dir (dired-current-directory)) + (rfiles (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files)) + (prompt "") + (comp 0) + (uncomp nil) + (total (length files)) + elt) + (mapcar (function + (lambda (fn) + (if (listp (setq elt + (dired-make-compressed-filename fn))) + (let* ((method (car (nth 3 elt))) + (count (assoc method uncomp))) + (if count + (setcdr count (1+ (cdr count))) + (setq uncomp (cons (cons method 1) uncomp)))) + (setq comp (1+ comp))))) + files) + (if (/= comp 0) + (setq prompt + (format "%s %d" + (car + (nth 2 + (assq dired-compression-method + dired-compression-method-alist))) + comp))) + (if uncomp + (let ((case-fold-search t) + method) + (or (string-equal prompt "") + (setq prompt (concat prompt "; "))) + (setq uncomp + (sort + (mapcar + (function + (lambda (elt) + (setq method (car elt)) + (if (string-equal method "gzip") + (setq method "gunzip") + (or (string-match "^un" method) + (setq method (concat "un" method)))) + (setcar elt method) + elt)) + uncomp) + (function + (lambda (x y) + (string< (car x) (car y)))))) + (setq prompt + (concat prompt + (mapconcat + (function + (lambda (elt) + (format "%s %d" (car elt) (cdr elt)))) + uncomp ", "))))) + (cond + ((= (length rfiles) 1) + (setq prompt (format "%s %s? " + ;; Don't need the number 1 + (substring prompt 0 -2) + (car rfiles)))) + ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp)) + (setq prompt (format "%s? Total: %d file%s " prompt total + (dired-plural-s total)))) + ((setq prompt (format "%s file%s? " prompt + (dired-plural-s total))))) + (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) + (setq arg 0))))) + (list arg files))) + + (if (not (zerop arg)) + (dired-create-files + 'dired-compress-file + "Compress or Uncompress" + files + (function + (lambda (fn) + (let ((cfn (dired-make-compressed-filename fn))) + (if (stringp cfn) + cfn + (substring fn 0 (- (length (nth 1 cfn)))))))) + dired-keep-marker-compress nil t))) + +(defun dired-compress-subdir-files (&optional uncompress) + "Compress all uncompressed files in the current subdirectory. +With a prefix argument uncompresses all compressed files." + (interactive "P") + (let ((dir (dired-current-directory)) + files methods uncomp elt) + (save-excursion + (save-restriction + (narrow-to-region (dired-subdir-min) (dired-subdir-max)) + (dired-map-dired-file-lines + (function + (lambda (f) + (if uncompress + (and (listp (setq uncomp (dired-make-compressed-filename f))) + (let ((program (car (nth 3 uncomp)))) + (setq files (cons f files)) + (if (setq elt (assoc program methods)) + (setcdr elt (1+ (cdr elt))) + (setq methods (cons (cons program 1) methods))))) + (and (stringp (dired-make-compressed-filename f)) + (setq files (cons f files))))))))) + (if files + (let ((total (length files)) + (rfiles (mapcar + (function + (lambda (fn) + (dired-make-relative fn dir t))) + files)) + prompt) + (if uncompress + (progn + (setq prompt (mapconcat + (function + (lambda (x) + (format "%s %d" + (if (string-equal (car x) "gzip") + "gunzip" + (if (string-match "^un" (car x)) + (car x) + (concat "un" (car x)))) + (cdr x)))) + methods ", ")) + (cond + ((= total 1) + (setq prompt + (concat (substring prompt 0 -1) (car rfiles) "? "))) + ((= (length methods) 1) + (setq prompt + (format "%s file%s? " prompt (dired-plural-s total)))) + (t + (setq prompt (format "%s? Total: %d file%s " prompt total + (dired-plural-s total)))))) + (setq prompt + (if (= total 1) + (format "%s %s? " dired-compression-method (car rfiles)) + (format "%s %d file%s? " + dired-compression-method total + (dired-plural-s total))))) + (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) + (dired-create-files + 'dired-compress-file + "Compress or Uncompress" + files + (function + (lambda (fn) + (let ((cfn (dired-make-compressed-filename fn))) + (if (stringp cfn) + cfn + (substring fn 0 (- (length (nth 1 cfn)))))))) + dired-keep-marker-compress nil t))) + (message "No files need %scompressing in %s." + (if uncompress "un" "") + (dired-abbreviate-file-name dir))))) + +(defun dired-compress-file (file ok-flag) + ;; Compress or uncompress FILE. + ;; If ok-flag is non-nil, it is OK to overwrite an existing + ;; file. How well this actually works may depend on the compression + ;; program. + ;; Return the name of the compressed or uncompressed file. + (let ((handler (find-file-name-handler file 'dired-compress-file))) + (if handler + (funcall handler 'dired-compress-file file ok-flag) + (let ((compressed-fn (dired-make-compressed-filename file)) + (err-buff (get-buffer-create " *dired-check-process output*"))) + (save-excursion + (set-buffer err-buff) + (erase-buffer) + (cond ((file-symlink-p file) + (signal 'file-error (list "Error compressing file" + file "a symbolic link"))) + ((listp compressed-fn) + (message "Uncompressing %s..." file) + (let* ((data (nth 3 compressed-fn)) + (ret + (apply 'call-process + (car data) file t nil + (append (cdr data) + (and ok-flag + (list (nth 4 compressed-fn))) + (list file))))) + (if (or (and (integerp ret) (/= ret 0)) + (not (bobp))) + (signal 'file-error + (nconc + (list "Error uncompressing file" + file) + (and (not (bobp)) + (list + (progn + (goto-char (point-min)) + (buffer-substring + (point) (progn (end-of-line) + (point)))))))))) + (message "Uncompressing %s...done" file) + (dired-remove-file file) + (let ((to (substring file 0 + (- (length (nth 1 compressed-fn)))))) + ;; rename any buffers + (and (get-file-buffer file) + (save-excursion + (set-buffer (get-file-buffer file)) + (let ((modflag (buffer-modified-p))) + ;; kills write-file-hooks + (set-visited-file-name to) + (set-buffer-modified-p modflag)))) + to)) + ((stringp compressed-fn) + (message "Compressing %s..." file) + (let* ((data (assq dired-compression-method + dired-compression-method-alist)) + (compr-args (nth 2 data)) + (ret + (apply 'call-process + (car compr-args) file t nil + (append (cdr compr-args) + (and ok-flag + (list (nth 4 data))) + (list file))))) + (if (or (and (integerp ret) (/= ret 0)) + (not (bobp))) + (signal 'file-error + (nconc + (list "Error compressing file" + file) + (and (not (bobp)) + (list + (progn + (goto-char (point-min)) + (buffer-substring + (point) (progn (end-of-line) + (point)))))))))) + (message "Compressing %s...done" file) + (dired-remove-file file) + ;; rename any buffers + (and (get-file-buffer file) + (save-excursion + (set-buffer (get-file-buffer file)) + (let ((modflag (buffer-modified-p))) + ;; kills write-file-hooks + (set-visited-file-name compressed-fn) + (set-buffer-modified-p modflag)))) + compressed-fn) + (t (error "Strange error in dired-compress-file.")))))))) + +(defun dired-make-compressed-filename (name &optional method) + ;; If NAME is in the syntax of a compressed file (according to + ;; dired-compression-method-alist), return the data (a list) from this + ;; alist on how to uncompress it. Otherwise, return a string, the + ;; compressed form of this file name. This is computed using the optional + ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of + ;; dired-compression-method is used. + (let ((handler (find-file-name-handler + name 'dired-make-compressed-filename))) + (if handler + (funcall handler 'dired-make-compressed-filename name method) + (let ((alist dired-compression-method-alist) + (len (length name)) + ext ext-len result) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal ext (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist)))) + (or result + (concat name + (nth 1 (or (assq (or method dired-compression-method) + dired-compression-method-alist) + (error "Unknown compression method: %s" + (or method dired-compression-method)))))) + )))) + +;;; end of dired-cmpr.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-diff.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-diff.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,164 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-diff.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Support for diff and related commands. +;; Author: Sandy Rutherford +;; Created: Fri Jun 24 08:50:20 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +(provide 'dired-diff) +(require 'dired) + +(defvar emerge-last-dir-input) +(defvar emerge-last-dir-output) +(defvar emerge-last-dir-ancestor) +(defvar diff-switches) + +(defun dired-diff-read-file-name (prompt) + ;; Read and return a file name for diff. + (let* ((mark-active t) + (default (and (mark) + (save-excursion + (goto-char (mark)) + (dired-get-filename nil t))))) + (read-file-name (format "%s %s with: %s" + prompt (dired-get-filename 'no-dir) + (if default + (concat "[" + (dired-make-relative + default + (dired-current-directory) t) + "] ") + "")) + (default-directory) default t))) + +(defun dired-diff-read-switches (switchprompt) + ;; Read and return a list of switches + (or (boundp 'diff-switches) + (require 'diff)) ; Make sure that `diff-switches' is defined. + (let* ((default (if (listp diff-switches) + (mapconcat 'identity diff-switches " ") + diff-switches)) + (switches + (read-string (format switchprompt default) default))) + (let (result (start 0)) + (while (string-match "\\(\\S-+\\)" switches start) + (setq result (cons (substring switches (match-beginning 1) + (match-end 1)) + result) + start (match-end 0))) + (nreverse result)))) + +(defun dired-diff (file &optional switches) + "Compare file at point with file FILE using `diff'. +FILE defaults to the file at the mark. +The prompted-for file is the first file given to `diff'. +With a prefix allows the switches for the diff program to be edited." + (interactive + (list + (dired-diff-read-file-name "Diff") + (and current-prefix-arg (dired-diff-read-switches "Options for diff: ")))) + (if switches + (diff file (dired-get-filename) switches) + (diff file (dired-get-filename)))) + +(defun dired-backup-diff (&optional switches) + "Diff this file with its backup file or vice versa. +Uses the latest backup, if there are several numerical backups. +If this file is a backup, diff it with its original. +The backup file is the first file given to `diff'." + (interactive (list (and current-prefix-arg + (dired-diff-read-switches "Diff with switches: ")))) + (if switches + (diff-backup (dired-get-filename) switches) + (diff-backup (dired-get-filename)))) + +(defun dired-emerge (arg file out-file) + "Merge file at point with FILE using `emerge'. +FILE defaults to the file at the mark." + (interactive + (let ((file (dired-diff-read-file-name "Merge"))) + (list + current-prefix-arg + file + (and current-prefix-arg (emerge-read-file-name + "Output file" + emerge-last-dir-output + (dired-abbreviate-file-name file) file))))) + (emerge-files arg file (dired-get-filename) out-file)) + +(defun dired-emerge-with-ancestor (arg file ancestor file-out) + "Merge file at point with FILE, using a common ANCESTOR file. +FILE defaults to the file at the mark." + (interactive + (let ((file (dired-diff-read-file-name "Merge"))) + (list + current-prefix-arg + file + (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor nil file) + (and current-prefix-arg (emerge-read-file-name + "Output file" + emerge-last-dir-output + (dired-abbreviate-file-name file) file))))) + (emerge-files-with-ancestor arg file (dired-get-filename) + ancestor file-out)) + +(defun dired-ediff (file) + "Ediff file at point with FILE. +FILE defaults to the file at the mark." + (interactive (list (dired-diff-read-file-name "Ediff"))) + (ediff-files file (dired-get-filename))) + +(defun dired-epatch (file) + "Patch file at point using `epatch'." + (interactive + (let ((file (dired-get-filename))) + (list + (and (or (memq 'patch dired-no-confirm) + (y-or-n-p (format "Patch %s? " + (file-name-nondirectory file)))) + file)))) + (if file + (ediff-patch-file file) + (message "No file patched."))) + +;;; Autoloads + +;;; Diff (diff) + +(autoload 'diff "diff" "Diff two files." t) +(autoload 'diff-backup "diff" + "Diff this file with its backup or vice versa." t) + +;;; Emerge + +(autoload 'emerge-files "emerge" "Merge two files." t) +(autoload 'emerge-files-with-ancestor "emerge" + "Merge two files having a common ancestor." t) +(autoload 'emerge-read-file-name "emerge") + +;; Ediff + +(autoload 'ediff-files "ediff" "Ediff two files." t) +(autoload 'ediff-patch-file "ediff" "Patch a file." t) + +;;; end of dired-diff.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-fsf.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-fsf.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,684 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-fsf.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired functions for V19 of the original GNU Emacs from FSF +;; Created: Sat Jan 29 01:38:49 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; Requirements and provisions +(provide 'dired-fsf) +(require 'dired) + +;;;; Variables to set. + +(setq dired-modeline-tracking-cmds '(mouse-set-point)) + +;;;; Support for text properties + +(defun dired-insert-set-properties (beg end) + ;; Sets the text properties for the file names. + (save-excursion + (goto-char beg) + (beginning-of-line) + (let ((eol (save-excursion (end-of-line) (point))) + (bol (point))) + (while (< (point) end) + (setq eol (save-excursion (end-of-line) (point))) + (if (dired-manual-move-to-filename nil bol eol) + (dired-set-text-properties + (point) (dired-manual-move-to-end-of-filename nil bol eol))) + (goto-char (setq bol (1+ eol))))))) + +(defun dired-remove-text-properties (start end &optional object) + ;; Removes text properties. Called in popup buffers. + (remove-text-properties start end '(mouse-face dired-file-name) object)) + +(defun dired-set-text-properties (start end) + ;; Sets dired's text properties + (put-text-property start end 'mouse-face 'highlight) + (put-text-property start end 'dired-file-name t)) + +(defun dired-move-to-filename (&optional raise-error bol eol) + (or bol (setq bol (save-excursion + (skip-chars-backward "^\n\r") + (point)))) + (or eol (setq eol (save-excursion + (skip-chars-forward "^\n\r") + (point)))) + (goto-char bol) + (let ((spot (next-single-property-change bol 'dired-file-name nil eol))) + (if (= spot eol) + (if raise-error + (error "No file on this line") + nil) + (goto-char spot)))) + +(defun dired-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (get-text-property (point) 'dired-file-name nil) + (goto-char (next-single-property-change (point) 'dired-file-name + nil eol)) + (and (null no-error) (error "No file on this line")))) + +;; Text properties do not work properly in pre-19.26. + +(if (or (not (boundp 'emacs-major-version)) + (= emacs-major-version 19)) + (progn + (if (not (boundp 'emacs-minor-version)) + ;; Argument structure of where-is-internal went through some + ;; changes. + (defun dired-key-description (cmd &rest prefixes) + ;; Return a key description string for a menu. + ;; If prefixes are given, they should be either strings, + ;; integers, or 'universal-argument. + (let ((key (where-is-internal cmd dired-mode-map nil t))) + (if key + (key-description + (apply 'vconcat + (append + (mapcar + (function + (lambda (x) + (if (eq x 'universal-argument) + (where-is-internal 'universal-argument + dired-mode-map nil t) + x))) + prefixes) + (list key)))) + "")))) + (if (or (not (boundp 'emacs-minor-version)) + (< emacs-minor-version 26)) + (progn + (fset 'dired-insert-set-properties 'ignore) + (fset 'dired-remove-text-properties 'ignore) + (fset 'dired-set-text-properties 'ignore) + (fset 'dired-move-to-filename 'dired-manual-move-to-filename) + (fset 'dired-move-to-end-of-filename + 'dired-manual-move-to-end-of-filename))))) + +;;;; Keymaps + +;;; Caching Menus + +(defun dired-menu-item (menu-item cmd width &rest prefixes) + ;; Return a key description string for a menu. If prefixes are given, + ;; they should be either characters, or 'universal-argument. + (let ((desc (apply 'dired-key-description cmd prefixes))) + (if (string-equal desc "") + menu-item + (concat menu-item + (make-string + (max (- width (length menu-item) (length desc) 2) 1) 32) + "(" desc ")")))) + +(defun dired-cache-key (keymap event cmd &rest prefixes) + ;; Caches a keybinding for cms in a menu keymap. + ;; This is able to handle prefix keys. + (let ((desc (apply 'dired-key-description cmd prefixes))) + (or (string-equal desc "") + (progn + (let ((elt (assq event keymap))) + (if elt + (let ((tail (cdr elt))) + (setcdr tail + (cons + (cons + nil (concat " (" desc ")")) + (cdr tail)))))))))) + +;; Don't cache keys in old emacs versions. Is 23 the right cut-off point? +(if (or (not (boundp 'emacs-minor-version)) + (< emacs-minor-version 23)) + (fset 'dired-cache-key 'ignore)) + +(defvar dired-visit-popup-menu nil) +;; Menus of commands in the Visit popup menu. +(defvar dired-do-popup-menu nil) +;; Menu of commands in the dired Do popup menu. + +;; Menus for the menu bar. +(defvar dired-subdir-menu + (cons "Subdir" (make-sparse-keymap "Subdir"))) +(defvar dired-mark-menu + (cons "Mark" (make-sparse-keymap "Mark"))) +(defvar dired-do-menu + (cons "Do" (make-sparse-keymap "Do"))) +(defvar dired-regex-menu + (cons "Regexp" (make-sparse-keymap "Regex"))) +(defvar dired-look-menu + (cons "Look" (make-sparse-keymap "Look"))) +(defvar dired-sort-menu + (cons "Sort" (make-sparse-keymap "Sort"))) +(defvar dired-help-menu nil) + +(defun dired-setup-menus () + + ;; popup menu + + (setq dired-visit-popup-menu + (list + (cons (dired-menu-item "Find File" 'dired-find-file 35) + 'dired-advertised-find-file) + (cons (dired-menu-item "Find in Other Window" + 'dired-find-file-other-window 35) + 'dired-find-file-other-window) + (cons (dired-menu-item "Find in Other Frame" + 'dired-find-file-other-frame 35) + 'dired-find-file-other-frame) + (cons (dired-menu-item "View File" 'dired-view-file 35) + 'dired-view-file) + (cons (dired-menu-item "Display in Other Window" + 'dired-find-file-other-window 35 + 'universal-argument) + 'dired-display-file))) + + ;; Operate popup menu + + (setq dired-do-popup-menu + (list + (cons (dired-menu-item "Copy to..." 'dired-do-copy 35 1) + 'dired-do-copy) + (cons (dired-menu-item "Rename to..." 'dired-do-rename 35 1) + 'dired-do-rename) + (cons (dired-menu-item "Compress/Uncompress" 'dired-do-compress + 35 1) 'dired-do-compress) + (cons (dired-menu-item "Uuencode/Uudecode" 'dired-do-uucode + 35 1) 'dired-do-uucode) + (cons (dired-menu-item "Change Mode..." 'dired-do-chmod 35 1) + 'dired-do-chmod) + (cons (dired-menu-item "Change Owner..." 'dired-do-chown 35 1) + 'dired-do-chown) + (cons (dired-menu-item "Change Group..." 'dired-do-chgrp 35 1) + 'dired-do-chgrp) + (cons (dired-menu-item "Load" 'dired-do-load 35 1) + 'dired-do-load) + (cons (dired-menu-item "Byte-compile" 'dired-do-byte-compile 35 1) + 'dired-do-byte-compile) + (cons (dired-menu-item "Hardlink to..." 'dired-do-hardlink 35 1) + 'dired-do-hardlink) + (cons (dired-menu-item "Symlink to..." 'dired-do-symlink 35 1) + 'dired-do-symlink) + (cons (dired-menu-item "Relative Symlink to..." + 'dired-do-relsymlink 35 1) + 'dired-do-relsymlink) + (cons (dired-menu-item "Shell Command..." + 'dired-do-shell-command 35 1) + 'dired-do-shell-command) + (cons (dired-menu-item "Background Shell Command..." + 'dired-do-background-shell-command 35 1) + 'dired-do-background-shell-command) + (cons (dired-menu-item "Delete" 'dired-do-delete 35 1) + 'dired-do-delete))) + + ;; Subdir Menu-bar Menu + + (define-key dired-mode-map [menu-bar subdir] dired-subdir-menu) + (define-key dired-mode-map [menu-bar subdir uncompress-subdir-files] + (cons "Uncompress Compressed Files" + (function + (lambda () (interactive) (dired-compress-subdir-files t))))) + (dired-cache-key dired-subdir-menu 'uncompress-subdir-files + 'dired-compress-subdir-files 'universal-argument) + (define-key dired-mode-map [menu-bar subdir compress-subdir-files] + '("Compress Uncompressed Files" . dired-compress-subdir-files)) + (define-key dired-mode-map [menu-bar subdir flag] + '("Flag Files for Deletion" . dired-flag-subdir-files)) + (define-key dired-mode-map [menu-bar subdir mark] + '("Mark Files" . dired-mark-subdir-files)) + (define-key dired-mode-map [menu-bar subdir redisplay] + '("Redisplay Subdir" . dired-redisplay-subdir)) + (define-key dired-mode-map [menu-bar subdir subdir-separator] + '("-- Commands on All Files in Subdir --")) + (define-key dired-mode-map [menu-bar subdir kill-subdir] + '("Kill This Subdir" . dired-kill-subdir)) + (define-key dired-mode-map [menu-bar subdir create-directory] + '("Create Directory..." . dired-create-directory)) + (define-key dired-mode-map [menu-bar subdir insert] + '("Insert This Subdir" . dired-maybe-insert-subdir)) + (define-key dired-mode-map [menu-bar subdir down-dir] + '("Down Dir" . dired-down-directory)) + (define-key dired-mode-map [menu-bar subdir up-dir] + '("Up Dir" . dired-up-directory)) + (define-key dired-mode-map [menu-bar subdir prev-dirline] + '("Prev Dirline" . dired-prev-dirline)) + (define-key dired-mode-map [menu-bar subdir next-dirline] + '("Next Dirline" . dired-next-dirline)) + (define-key dired-mode-map [menu-bar subdir prev-subdir] + '("Prev Subdir" . dired-prev-subdir)) + (define-key dired-mode-map [menu-bar subdir next-subdir] + '("Next Subdir" . dired-next-subdir)) + + ;; Mark Menu-bar Menu + + (define-key dired-mode-map [menu-bar mark] dired-mark-menu) + (define-key dired-mode-map [menu-bar mark mark-from-compilation-buffer] + '("Mark Files from Compile Buffer..." . dired-mark-files-compilation-buffer)) + (define-key dired-mode-map [menu-bar mark mark-from-other-buffer] + '("Mark Files from Other Dired" . + dired-mark-files-from-other-dired-buffer)) + (define-key dired-mode-map [menu-bar mark mark-separator] + '("--")) + (define-key dired-mode-map [menu-bar mark marker-char-right] + '("Marker stack right" . dired-marker-stack-right)) + (define-key dired-mode-map [menu-bar mark marker-char-left] + '("Marker stack left" . dired-marker-stack-left)) + (define-key dired-mode-map [menu-bar mark restore-marker] + '("Restore marker char" . dired-restore-marker-char)) + (define-key dired-mode-map [menu-bar mark add-marker] + '("Set new marker char..." . dired-set-marker-char)) + (define-key dired-mode-map [menu-bar mark auto-save-files] + '("Flag Auto-save Files" . dired-flag-auto-save-files)) + (define-key dired-mode-map [menu-bar mark backup-files] + '("Flag Backup Files" . dired-flag-backup-files)) + (define-key dired-mode-map [menu-bar mark executables] + '("Mark Executables" . dired-mark-executables)) + (define-key dired-mode-map [menu-bar mark directory] + '("Mark Old Backups" . dired-clean-directory)) + (define-key dired-mode-map [menu-bar mark directories] + '("Mark Directories" . dired-mark-directories)) + (define-key dired-mode-map [menu-bar mark symlinks] + '("Mark Symlinks" . dired-mark-symlinks)) + (define-key dired-mode-map [menu-bar mark toggle] + (cons "Toggle Marks..." + (function (lambda () (interactive) + (let ((current-prefix-arg t)) + (call-interactively 'dired-change-marks)))))) + (dired-cache-key dired-mark-menu 'toggle 'dired-change-marks + 'universal-argument) + (define-key dired-mode-map [menu-bar mark unmark-all] + '("Unmark All" . dired-unmark-all-files)) + (define-key dired-mode-map [menu-bar mark marks] + '("Change Marks..." . dired-change-marks)) + (define-key dired-mode-map [menu-bar mark prev] + '("Previous Marked" . dired-prev-marked-file)) + (define-key dired-mode-map [menu-bar mark next] + '("Next Marked" . dired-next-marked-file)) + + ;; Do Menu-bar Menu + + (define-key dired-mode-map [menu-bar do] + dired-do-menu) + (define-key dired-mode-map [menu-bar do do-popup] + (cons "Operate on file menu >" + 'dired-do-popup-menu-internal)) + (dired-cache-key dired-do-menu 'do-popup + 'dired-do-popup-menu) + (define-key dired-mode-map [menu-bar do visit-popup] + (cons "Visit file menu >" + 'dired-visit-popup-menu-internal)) + (dired-cache-key dired-do-menu 'visit-popup + 'dired-visit-popup-menu) + (define-key dired-mode-map [menu-bar do delete] + '("Delete Marked Files" . dired-do-delete)) + (define-key dired-mode-map [menu-bar do background-command] + '("Background Shell Command..." . dired-do-background-shell-command)) + (define-key dired-mode-map [menu-bar do command] + '("Shell Command..." . dired-do-shell-command)) + (define-key dired-mode-map [menu-bar do symlink] + '("Symlink to..." . dired-do-symlink)) + (define-key dired-mode-map [menu-bar do hardlink] + '("Hardlink to..." . dired-do-hardlink)) + (define-key dired-mode-map [menu-bar do compile] + '("Byte-compile" . dired-do-byte-compile)) + (define-key dired-mode-map [menu-bar do load] + '("Load" . dired-do-load)) + (define-key dired-mode-map [menu-bar do chgrp] + '("Change Group..." . dired-do-chgrp)) + (define-key dired-mode-map [menu-bar do chown] + '("Change Owner..." . dired-do-chown)) + (define-key dired-mode-map [menu-bar do chmod] + '("Change Mode..." . dired-do-chmod)) + (define-key dired-mode-map [menu-bar do print] + '("Print..." . dired-do-print)) + (define-key dired-mode-map [menu-bar do uucode] + '("Uuencode/Uudecode" . dired-do-uucode)) + (define-key dired-mode-map [menu-bar do compress] + '("Compress/Uncompress" . dired-do-compress)) + (define-key dired-mode-map [menu-bar do expunge] + '("Expunge File Flagged for Deletion" . dired-expunge-deletions)) + (define-key dired-mode-map [menu-bar do rename] + '("Rename to..." . dired-do-rename)) + (define-key dired-mode-map [menu-bar do copy] + '("Copy to..." . dired-do-copy)) + +;; Regex Menu-bar Menu + + (define-key dired-mode-map [menu-bar regex] dired-regex-menu) + (define-key dired-mode-map [menu-bar regex show-omit-regexp] + (cons "Show Omit Regex" + (function + (lambda () + (interactive) + (let ((current-prefix-arg 0)) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'show-omit-regexp + 'dired-add-omit-regexp 0) + (define-key dired-mode-map [menu-bar regex remove-omit-extension] + (cons "Remove Omit Extension..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg '(16))) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'remove-omit-extension + 'dired-add-omit-regexp 'universal-argument + 'universal-argument) + (define-key dired-mode-map [menu-bar regex add-omit-extension] + (cons "Add Omit Extension..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg '(4))) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'add-omit-extension + 'dired-add-omit-regexp 'universal-argument) + (define-key dired-mode-map [menu-bar regex remove-omit-regexp] + (cons "Remove Omit Regex..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg 1)) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'remove-omit-regexp + 'dired-add-omit-regexp 1) + (define-key dired-mode-map [menu-bar regex add-omit-regexp] + '("Add Omit Regex..." . dired-add-omit-regexp)) + (define-key dired-mode-map [menu-bar regex separator] + '("--")) + (define-key dired-mode-map [menu-bar regex relsymlink] + '("Relative Symlink..." . dired-do-relsymlink-regexp)) + (define-key dired-mode-map [menu-bar regex symlink] + '("Symlink..." . dired-do-symlink-regexp)) + (define-key dired-mode-map [menu-bar regex hardlink] + '("Hardlink..." . dired-do-hardlink-regexp)) + (define-key dired-mode-map [menu-bar regex rename] + '("Rename..." . dired-do-rename-regexp)) + (define-key dired-mode-map [menu-bar regex copy] + '("Copy..." . dired-do-copy-regexp)) + (define-key dired-mode-map [menu-bar regex upcase] + '("Upcase" . dired-upcase)) + (define-key dired-mode-map [menu-bar regex downcase] + '("Downcase" . dired-downcase)) + (define-key dired-mode-map [menu-bar regex dired-flag-extension] + '("Flag Files with Extension..." . dired-flag-extension)) + (define-key dired-mode-map [menu-bar regex flag] + '("Flag..." . dired-flag-files-regexp)) + (define-key dired-mode-map [menu-bar regex mark-extension] + '("Mark Files with Extension..." . dired-mark-extension)) + (define-key dired-mode-map [menu-bar regex mark] + '("Mark..." . dired-mark-files-regexp)) + + ;; Look Menu-bar Menu + + (define-key dired-mode-map [menu-bar look] dired-look-menu) + (define-key dired-mode-map [menu-bar look patch] + '("Patch File" . dired-epatch)) + (define-key dired-mode-map [menu-bar look ediff] + '("Ediff Files..." . dired-ediff)) + (define-key dired-mode-map [menu-bar look emerge-with-ancestor] + '("Merge Files Having Common Ancestor..." . dired-emerge-with-ancestor)) + (define-key dired-mode-map [menu-bar look emerge] + '("Merge Files..." . dired-emerge)) + (define-key dired-mode-map [menu-bar look backup-diff] + '("Diff with Backup" . dired-backup-diff)) + (define-key dired-mode-map [menu-bar look diff] + '("Diff File..." . dired-diff)) + ;; Put in a separator line. + (define-key dired-mode-map [menu-bar look look-separator] + '("--")) + (define-key dired-mode-map [menu-bar look tags-query-replace] + '("Tags Query Replace..." . dired-do-tags-query-replace)) + (define-key dired-mode-map [menu-bar look tags-search] + '("Tags Search for..." . dired-do-tags-search)) + (define-key dired-mode-map [menu-bar look grep] + '("Grep for..." . dired-do-grep)) + + ;; Sort Menu-bar Menu + + (define-key dired-mode-map [menu-bar sort] dired-sort-menu) + (define-key dired-mode-map [menu-bar sort redisplay-killed] + (cons "Redisplay Killed Lines" + (function (lambda () (interactive) (dired-do-kill-file-lines 0))))) + (dired-cache-key dired-sort-menu 'redisplay-killed + 'dired-do-kill-file-lines 0) + (define-key dired-mode-map [menu-bar sort kill] + '("Kill Marked Lines" . dired-do-kill-file-lines)) + (define-key dired-mode-map [menu-bar sort toggle-omit] + '("Toggle Omit" . dired-omit-toggle)) + (define-key dired-mode-map [menu-bar sort hide-subdir] + '("Hide Subdir" . dired-hide-subdir)) + (define-key dired-mode-map [menu-bar sort hide-all] + '("Hide All Subdirs" . dired-hide-all)) + (define-key dired-mode-map [menu-bar sort sort-separator] + '("--")) + (define-key dired-mode-map [menu-bar sort entire-edit] + (cons "Edit Switches for Entire Buffer..." + (function (lambda () (interactive) + (dired-sort-toggle-or-edit '(16)))))) + (dired-cache-key dired-sort-menu 'entire-edit + 'dired-sort-toggle-or-edit 'universal-argument + 'universal-argument) + (define-key dired-mode-map [menu-bar sort entire-name] + (cons "Sort Entire Buffer by Name" + (function (lambda () (interactive) + (dired-sort-toggle-or-edit 'name))))) + (dired-cache-key dired-sort-menu 'entire-name 'dired-sort-toggle-or-edit + 'universal-argument) + (define-key dired-mode-map [menu-bar sort entire-date] + (cons "Sort Entire Buffer by Date" + (function (lambda () (interactive) + (dired-sort-toggle-or-edit 'date))))) + (dired-cache-key dired-sort-menu 'entire-date 'dired-sort-toggle-or-edit + 'universal-argument) + (define-key dired-mode-map [menu-bar sort new-edit] + (cons "Edit Default Switches for Inserted Subdirs..." + (function (lambda () (interactive) (dired-sort-toggle-or-edit 2))))) + (dired-cache-key dired-sort-menu 'new-edit 'dired-sort-toggle-or-edit 2) + (define-key dired-mode-map [menu-bar sort edit] + (cons "Edit Switches for Current Subdir..." + (function (lambda () (interactive) (dired-sort-toggle-or-edit 1))))) + (dired-cache-key dired-sort-menu 'edit 'dired-sort-toggle-or-edit 1) + (define-key dired-mode-map [menu-bar sort show] + (cons "Show Current Switches" + (function (lambda () (interactive) (dired-sort-toggle-or-edit 0))))) + (dired-cache-key dired-sort-menu 'show 'dired-sort-toggle-or-edit 0) + (define-key dired-mode-map [menu-bar sort toggle] + '("Toggle Current Subdir by Name/Date" . dired-sort-toggle-or-edit)) + + ;; Help Menu-bar Menu + + (or dired-help-menu + (setq dired-help-menu + (if (and (boundp 'menu-bar-help-menu) (keymapp menu-bar-help-menu)) + (cons "Help" (cons 'keymap (cdr menu-bar-help-menu))) + (cons "Help" (make-sparse-keymap "Help"))))) + (define-key dired-mode-map [menu-bar dired-help] dired-help-menu) + (define-key dired-mode-map [menu-bar dired-help help-separator] + '("--")) + (define-key dired-mode-map [menu-bar dired-help dired-bug] + '("Report Dired Bug" . dired-report-bug)) + (define-key dired-mode-map [menu-bar dired-help dired-var-apropos] + (cons "Dired Variable Apropos" + (function (lambda () + (interactive) + (let ((current-prefix-arg t)) + (call-interactively 'dired-apropos)))))) + (dired-cache-key dired-help-menu 'dired-var-apropos + 'dired-apropos 'universal-argument) + (define-key dired-mode-map [menu-bar dired-help dired-apropos] + '("Dired Command Apropos" . dired-apropos)) + (define-key dired-mode-map [menu-bar dired-help dired-info] + (cons "Dired Info Manual" + (function (lambda () + (interactive) + (dired-describe-mode t))))) + (dired-cache-key dired-help-menu 'dired-info 'dired-describe-mode + 'universal-argument) + (define-key dired-mode-map [menu-bar dired-help dired-describe-mode] + '("Describe Dired" . dired-describe-mode)) + (define-key dired-mode-map [menu-bar dired-help dired-summary] + '("Dired Summary Help" . dired-summary))) + +(add-hook 'dired-setup-keys-hook 'dired-setup-menus) + +;;; Mouse functions + +(defun dired-mouse-find-file (event) + "In dired, visit the file or directory name you click on." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (dired-find-file)) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-mark (event) + "In dired, mark the file name that you click on. +If the file name is already marked, this unmarks it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (beginning-of-line) + (if (looking-at dired-re-mark) + (dired-unmark 1) + (dired-mark 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-flag (event) + "In dired, flag for deletion the file name that you click on. +If the file name is already flag, this unflags it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (beginning-of-line) + (if (char-equal (following-char) dired-del-marker) + (dired-unflag 1) + (dired-flag-file-deletion 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-get-target (event) + "In dired, put a copy of the selected directory in the active minibuffer." + (interactive "e") + (let ((obuff (current-buffer)) + mb) + (set-buffer (window-buffer (posn-window (event-end event)))) + (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) + (let (dir) + (goto-char (posn-point (event-end event))) + (setq dir (dired-current-directory)) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (set-buffer obuff) + (if mb + (error "No directory specified") + (error "No active minibuffer"))))) + +(defun dired-visit-popup-menu (event) + "Popup a menu to visit the moused file." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (save-excursion + (goto-char (posn-point (event-end event))) + (dired-visit-popup-menu-internal event)))) + +(defun dired-visit-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + fun) + (dired-remove-text-properties 0 (length fn) fn) + (setq fun (x-popup-menu + event + (list "Visit popup menu" + (cons + (concat "Visit " fn " with") + dired-visit-popup-menu)))) + (if fun (funcall fun)))) + +(defun dired-do-popup-menu (event) + ;; Pop up a menu do an operation on the moused file. + (interactive "e") + (let ((obuff (current-buffer))) + (unwind-protect + (progn + (set-buffer (window-buffer (posn-window (event-end event)))) + (dired-save-excursion + (goto-char (posn-point (event-end event))) + (dired-do-popup-menu-internal event))) + (set-buffer obuff)))) + +(defun dired-do-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + fun) + (dired-remove-text-properties 0 (length fn) fn) + (setq fun (x-popup-menu + event + (list "Do popup menu" + (cons + (concat "Do operation on " fn) + dired-do-popup-menu)))) + (dired-save-excursion + (if fun (let ((current-prefix-arg 1)) + (call-interactively fun)))))) + +;;; Key maps + +;; Get rid of the Edit menu bar item to save space. +(define-key dired-mode-map [menu-bar edit] 'undefined) +;; We have our own help item +(define-key dired-mode-map [menu-bar help] 'undefined) +(define-key dired-mode-map [mouse-2] 'dired-mouse-find-file) +(define-key dired-mode-map [S-mouse-1] 'dired-mouse-mark) +(define-key dired-mode-map [C-S-mouse-1] 'dired-mouse-flag) +(define-key dired-mode-map [down-mouse-3] 'dired-visit-popup-menu) +;; This can be useful in dired, so move to double click. +(define-key dired-mode-map [double-mouse-3] 'mouse-save-then-kill) +(define-key dired-mode-map [C-down-mouse-2] 'dired-do-popup-menu) +(define-key dired-mode-map [M-mouse-2] 'dired-mouse-get-target) + +(or (memq 'dired-help menu-bar-final-items) + (setq menu-bar-final-items (cons 'dired-help menu-bar-final-items))) + +;;; end of dired-fsf.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-grep.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-grep.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,482 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-grep.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Support for running grep on marked files in a dired buffer. +;; Author: Sandy Rutherford +;; Created: Tue Jul 13 22:59:37 1993 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Copyright (C) 1993 Sandy Rutherford + +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +;;; The user-level command in this file is dired-grep-file. The command +;;; grep is defined in compile.el. This file does not change that command. + +;;; Requirements and provisions + +(provide 'dired-grep) +(or (fboundp 'file-local-copy) (require 'emacs-19)) +(or (fboundp 'generate-new-buffer) (require 'emacs-19)) +(require 'dired) + +;;; Variables + +(defvar dired-grep-program "grep" + "Name of program to use to grep files. +When used with the \"-n\" flag, program must precede each match with \"###:\", +where \"###\" is the line number of the match. +If there are grep programs which don't do this, we'll try to think of +some way to accomodate them.") + +(defvar dired-grep-switches nil + "*Switches to pass to the grep program. +This may be either a string or a list of strings. It is not necessary to +include \"-n\" as that switch is always used.") + +(defvar dired-grep-zcat-program "zcat" + "Name of program to cat compressed files.") + +(defvar dired-grep-compressed-file ".\\.\\(gz\\|[zZ]\\)$" + "Regexp to match names of compressed files.") + +(defvar dired-grep-pop-up-buffer t + "*If non-nil, the grep output is displayed in the other window upon +completion of the grep process.") + +(defvar dired-grep-results-buffer "*Dired Grep*" + "Name of buffer where grep results are logged.") + +(defvar dired-grep-mode-hook nil + "Hook run after going into grep-mode") + +(defvar grep-history nil + "History of previous grep patterns used.") + +(defvar dired-grep-parse-flags-cache nil) +(defvar dired-grep-parse-flags-cache-result nil) + +(defvar dired-grep-mode-map nil + "Keymap for dired-grep-mode buffers.") + +(if dired-grep-mode-map + () + (setq dired-grep-mode-map (make-keymap)) + (suppress-keymap dired-grep-mode-map) + (define-key dired-grep-mode-map "[" 'backward-page) + (define-key dired-grep-mode-map "]" 'forward-page) + (define-key dired-grep-mode-map ">" 'dired-grep-next-hit) + (define-key dired-grep-mode-map "<" 'dired-grep-previous-hit) + (define-key dired-grep-mode-map "n" 'dired-grep-advertized-next-hit) + (define-key dired-grep-mode-map "p" 'dired-grep-advertized-previous-hit) + (define-key dired-grep-mode-map "k" 'dired-grep-delete-line) + (define-key dired-grep-mode-map "d" 'dired-grep-delete-page) + (define-key dired-grep-mode-map "^" 'dired-grep-delete-preceding-pages) + (define-key dired-grep-mode-map "f" 'dired-grep-find-file) + (define-key dired-grep-mode-map "e" 'dired-grep-find-file) + (define-key dired-grep-mode-map "m" 'dired-grep-delete-misses) + (define-key dired-grep-mode-map "o" 'dired-grep-find-file-other-window) + (define-key dired-grep-mode-map "v" 'dired-grep-view-file) + (define-key dired-grep-mode-map "w" 'dired-grep-delete-grep-for) + (define-key dired-grep-mode-map "\C-_" 'dired-grep-undo) + (define-key dired-grep-mode-map "\C-xu" 'dired-grep-undo)) + +;;; Entry functions from dired.el + +(defun dired-grep (pattern flags) + ;; grep the file on the current line for PATTERN, using grep flags FLAGS. + ;; Return nil on success. Offending filename otherwise. + (let* ((file (dired-get-filename)) + (result (dired-grep-file pattern file flags))) + (and result + (progn + (dired-log (buffer-name (current-buffer)) (concat result "\n")) + file)))) + +(defun dired-do-grep (pattern &optional flags arg) + "Grep marked files for a pattern. With a \C-u prefix prompts for grep flags." + (interactive + (let* ((switches (if (consp current-prefix-arg) + (read-string "Switches for grep: ") + dired-grep-switches)) + (prompt (format "grep %sfor pattern" + (if (stringp switches) + (if (string-equal switches "") + switches + (concat switches " ")) + (if switches + (concat (mapconcat 'identity switches " ") " ") + "")))) + (pattern (dired-read-with-history (concat prompt ": ") + nil 'grep-history))) + (list pattern switches + (and (not (consp current-prefix-arg)) current-prefix-arg)))) + (dired-map-over-marks-check + (function + (lambda () + (dired-grep pattern flags))) + arg 'grep (concat "grep " flags (if flags " \"" "\"") pattern "\"") t)) + +;;; Utility functions + +(defun dired-grep-get-results-buffer () + ;; Return the buffer object of the dired-grep-results-buffer, creating and + ;; initializing it if necessary. + (let ((buffer (get-buffer dired-grep-results-buffer))) + (or buffer + (save-excursion + (set-buffer (setq buffer (get-buffer-create dired-grep-results-buffer))) + (dired-grep-mode) + buffer)))) + +;; Only define if undefined, in case efs has got to it already. +(or (fboundp 'dired-grep-delete-local-temp-file) + (defun dired-grep-delete-local-temp-file (file) + (condition-case nil (delete-file file) (error nil)))) + +;;; Commands in the dired-grep-results-buffer buffer. + +(defun dired-grep-mode () + "\\Mode for perusing grep output generated from dired. +The output is divided into pages, one page per grepped file. + +Summary of commands: + +Move to next grep hit \\[dired-grep-advertized-next-hit], \\[dired-grep-next-hit] +Move to previous grep hit \\[dired-grep-advertized-previous-hit], \\[dired-grep-previous-hit] +Move to output for next file \\[forward-page] +Move to output for previous file \\[backward-page] + +Delete the current grep line \\[dired-grep-delete-line] +Delete all output for current file \\[dired-grep-delete-page] +Delete all preceding pages \\[dired-grep-delete-preceding-pages] +Delete all pages for files with no hits \\[dired-grep-delete-misses] +Delete all pages which grep for the + same pattern as the current page \\[dired-grep-delete-grep-for] + +Find current grep hit in file \\[dired-grep-find-file] +Find current grep hit in other window \\[dired-grep-find-file-other-window] +View current grep hit \\[dired-grep-view-file] + +Undo changes to the grep buffer \\[dired-grep-undo] + +Keybindings: +\\{dired-grep-mode-map}" + (kill-all-local-variables) + (use-local-map dired-grep-mode-map) + (setq major-mode 'dired-grep-mode + mode-name "Dired-Grep" + buffer-read-only t) + (set (make-local-variable 'page-delimiter) "\n\n") + (run-hooks 'dired-grep-mode-hook)) + +(defun dired-grep-current-file-and-line () + ;; Returns a list \(FILENAME . LINE\) corresponding to the filename + ;; and line number associated with the position of the point in a + ;; grep buffer. Returns nil if there is none. + (save-excursion + (let (file line) + (and + (progn + (beginning-of-line) + (looking-at "[0-9]+:")) + (progn + (setq line (string-to-int (buffer-substring (point) + (1- (match-end 0))))) + (if (search-backward "\n\n" nil 'move) (forward-char 2)) + (looking-at "Hits for ")) + (progn + (forward-line 1) + (looking-at " ")) + (progn + (setq file (buffer-substring (match-end 0) + (progn (end-of-line) (1- (point))))) + (cons file line)))))) + +(defun dired-grep-find-file () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (progn + (find-file (car file)) + (goto-line (cdr file)) + (recenter '(4))) + (error "No file specified by this line.")))) + +(defun dired-grep-find-file-other-window () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (progn + (find-file-other-window (car file)) + (goto-line (cdr file)) + (recenter '(4))) + (error "No file specified by this line.")))) + +(defun dired-grep-view-file () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (let* ((fun (function + (lambda () (goto-line (cdr file)) (recenter '(4))))) + (view-hook + (if (boundp 'view-hook) + (if (and (listp view-hook) + (not (eq (car view-hook) 'lambda))) + (cons fun view-hook) + (list fun view-hook)) + fun))) + (view-file (car file))) + (error "No file specified by this line.")))) + +(defun dired-grep-next-hit (arg) + "Moves to the next, or next ARGth, grep hit." + (interactive "p") + (forward-line 1) + (if (re-search-forward "^[0-9]" nil 'move arg) + (goto-char (match-beginning 0)) + (error "No further grep hits"))) + +(defun dired-grep-previous-hit (arg) + "Moves to the previous, or previous ARGth, grep hit." + (interactive "p") + (beginning-of-line) + (or (re-search-backward "^[0-9]" nil 'move arg) + (error "No further grep hits"))) + +;; These are only so we can get a decent looking help buffer. +(fset 'dired-grep-advertized-next-hit 'dired-grep-next-hit) +(fset 'dired-grep-advertized-previous-hit 'dired-grep-previous-hit) + +(defun dired-grep-delete-page (arg) + "Deletes the current and ARG - 1 following grep output pages. +If ARG is negative, deletes preceding pages." + (interactive "p") + (let ((done 0) + (buffer-read-only nil) + (backward (< arg 0)) + start) + (if backward (setq arg (- arg))) + (while (and (< done arg) (not (if backward (bobp) (eobp)))) + (or (looking-at "^\n") + (if (search-backward "\n\n" nil 'move) (forward-char 1))) + (setq start (point)) + (if (search-forward "\n\n" nil 'move) (forward-char -1)) + (delete-region start (point)) + (and (bobp) (not (eobp)) (delete-char 1)) + (if backward (skip-chars-backward "\n")) + (setq done (1+ done))))) + +(defun dired-grep-delete-preceding-pages () + "Deletes the current, and all preceding pages from the grep buffer." + (interactive) + (let ((buffer-read-only nil)) + (if (looking-at "^\n") + (forward-char 1) + (search-forward "\n\n" nil 'move)) + (delete-region (point-min) (point)))) + +(defun dired-grep-delete-line (arg) + "Deletes the current line and ARG following lines from the grep buffer. +Only operates on lines which correspond to file lines for grep hits." + (interactive "p") + (let ((opoint (point)) + (buffer-read-only nil) + (backward (< arg 0)) + (done 0)) + (beginning-of-line) + (if backward (setq arg (- arg))) + (if (looking-at "[0-9]+:") + (while (< done arg) + (delete-region (point) (progn (forward-line 1) (point))) + (if backward (forward-line -1)) + (if (looking-at "[0-9]+:") + (setq done (1+ done)) + (setq done arg))) + ;; Do nothing. + (goto-char opoint)))) + +(defun dired-grep-delete-grep-for () + "Deletes all pages which grep some file for the pattern of the current page." + (interactive) + (save-excursion + ;; In case we happen to be right at the beginning of a page. + (or (eobp) (eolp) (forward-char 1)) + (forward-page -1) ; gets to the beginning of the page. + (let* ((eol (save-excursion (end-of-line) (point))) + (line (and (search-forward " grep " eol t) + (buffer-substring (point) eol)))) + (if line + (progn + (goto-char (point-min)) + (while (not (eobp)) + (let* ((eol (save-excursion (end-of-line) (point))) + (this-line (and (search-forward " grep " eol t) + (buffer-substring (point) eol)))) + (if (equal line this-line) + (progn + (dired-grep-delete-page 1) + (skip-chars-forward "\n")) + (or (eobp) (forward-page 1)))))))))) + +(defun dired-grep-delete-misses () + "Delete all pages for which there were no grep hits. +Deletes pages for which grep failed because of an error too." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at "Grep failed \\|No hits ") + (progn + (dired-grep-delete-page 1) + (skip-chars-forward "\n")) + (forward-page 1))))) + +(defun dired-grep-undo () + "Undoes deletions in a grep buffer." + (interactive) + (let (buffer-read-only) + (undo))) + +;;; Commands for grepping files. + +(defun dired-grep-parse-flags (string) + ;; Breaks a string of switches into a list. + (if (equal dired-grep-parse-flags-cache string) + dired-grep-parse-flags-cache-result + (let ((length (length string)) + (pointer 0) + (start 0) + (result nil)) + (while (and (< pointer length) (= (aref string pointer) ?\ )) + (setq pointer (1+ pointer))) + (while (< pointer length) + (setq start pointer) + (while (and (< pointer length) (/= (aref string pointer) ?\ )) + (setq pointer (1+ pointer))) + (setq result (cons (substring string start pointer) result)) + (while (and (< pointer length) (= (aref string pointer) ?\ )) + (setq pointer (1+ pointer)))) + (setq dired-grep-parse-flags-cache string + dired-grep-parse-flags-cache-result (nreverse result))))) + +(defun dired-grep-file (pattern file &optional flags) + "Grep for PATTERN in FILE. +Optional FLAGS are flags to pass to the grep program. +When used interactively, will prompt for FLAGS if a prefix argument is used." + (interactive + (let* ((switches (if (consp current-prefix-arg) + (read-string "Switches for grep: ") + dired-grep-switches)) + (prompt (format "grep %sfor pattern" + (if (stringp switches) + (if (string-match switches "^ *$") + "" + (concat switches " ")) + (if switches + (concat (mapconcat 'identity switches " ") " ") + "")))) + (pattern (dired-read-with-history (concat prompt ": ") + nil 'grep-history)) + (file (read-file-name (concat prompt " \"" pattern "\" in file :")))) + (list pattern file switches))) + (setq file (expand-file-name file)) + (if (listp flags) + (setq flags (mapconcat 'identity flags " ")) + (if (string-match "^ +$" flags) + (setq flags ""))) + (let ((file-buff (get-file-buffer file))) + (if (and file-buff (buffer-modified-p file-buff)) + (if (y-or-n-p (format "Save buffer %s? " (buffer-name file-buff))) + (save-excursion + (set-buffer file-buff) + (save-buffer))))) + (let ((buffer (dired-grep-get-results-buffer)) + (compressed (string-match dired-grep-compressed-file file)) + failed temp-file jka-compr-compression-info-list) + (setq temp-file + (condition-case err + (file-local-copy file) + (error (progn (setq failed (format "%s" err)) nil)))) + (or failed + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (let ((buffer-read-only nil) + pos-1 pos-2) + (or (bobp) (insert "\n")) + (setq pos-1 (point)) + (insert "Hits for grep ") + (or (string-equal flags "") (insert flags " ")) + (insert "\"" pattern "\" in\n " file ":\n") + (setq pos-2 (point)) + (condition-case err + (apply + 'call-process + (if compressed "sh" dired-grep-program) + (or temp-file file) + buffer t + (if compressed + (list "-c" (concat dired-grep-zcat-program + " |" dired-grep-program + " " flags " -n '" pattern "'")) + (append (dired-grep-parse-flags flags) + (list "-n" pattern)))) + (error (setq failed (format "%s" err)))) + (if failed + (progn + (if (= pos-2 (point-max)) + (progn + (goto-char (1- pos-2)) + (delete-char -1) + (insert "."))) + (goto-char pos-1) + (delete-char 4) + (insert "Grep failed") + failed) + (if (= pos-2 (point-max)) + (progn + (goto-char pos-1) + (delete-char 1) + (insert "No h") + (forward-line 1) + (end-of-line) + (delete-char -1) + (insert ".")) + (goto-char pos-2) + (or (looking-at "[0-9]+:") + (setq failed (buffer-substring pos-2 + (progn (end-of-line) + (point)))))))))) + (let ((curr-wind (selected-window))) + (unwind-protect + (progn + (pop-to-buffer buffer) + (goto-char (point-max))) + (select-window curr-wind))) + (if temp-file + (dired-grep-delete-local-temp-file temp-file)) + failed)) + +;;; Run the load hook + +(run-hooks 'dired-grep-load-hook) + +;;; end of dired-grep.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-help.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-help.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,398 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-help.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Obtaining help for dired +;; Modified: Sun Nov 20 21:10:47 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-help) +(require 'dired) +(autoload 'reporter-submit-bug-report "reporter") +(defvar reporter-version) ; For the byte-compiler. + +;;; Constants + +(defconst dired-bug-address "efs-bugs@cuckoo.hpl.hp.com") + +(defvar dired-documentation nil) + +;;; Functions + +(defun dired-documentation () + (or dired-documentation + (let ((18-p (string-equal "18." (substring emacs-version 0 3))) + (var-help-key (substitute-command-keys + (if (featurep 'ehelp) + "\\[electric-describe-variable]" + "\\[describe-variable]"))) + (standard-output (get-buffer-create " dired-help-temp"))) + (save-excursion + (set-buffer standard-output) + (unwind-protect + (setq dired-documentation + (substitute-command-keys + (format "\\The Directory Editor: + +For more detailed help, type \\[universal-argument] \\[dired-describe-mode] to start the info +documentation browser. + +In dired, you can edit a list of the files in a directory \(and optionally +its subdirectories in the `ls -lR' format\). + +Editing a directory means that you can visit, rename, copy, compress, +load, byte-compile files. You can change files' attributes, run shell +commands on files, or insert subdirectories into the edit buffer. You can +\"flag\" files for deletion or \"mark\" files for later commands, either one +file at a time or by all files matching certain criteria \(e.g., files that +match a certain regexp\). + +You move throughout the buffer using the usual cursor motion commands. +Letters no longer insert themselves, but execute commands instead. The +digits (0-9) are prefix arguments. + +Most commands operate either on all marked files or on the current file if +no files are marked. Use a numeric prefix argument to operate on the next +ARG files (or previous ARG if ARG < 0). Use the prefix argument `1' to +operate on the current file only. Prefix arguments override marks. Commands +which run a sub-process on a group of files will display a list of files +for which the sub-process failed. Typing \\[dired-why] will try to tell +you what went wrong. + +When editing several directories in one buffer, each directory acts as a +page, so \\[backward-page] and \\[forward-page] can be used to move between directories. + +Summary of commands: + +Motion Commands + move up to previous line \\[dired-next-line] + move down to next line \\[dired-previous-line] + move up to previous directory line \\[dired-prev-dirline] + move down to next directory line \\[dired-next-dirline] + move up to previous subdirectory \\[dired-advertised-prev-subdir] + move down to next subdirectory \\[dired-advertised-next-subdir] + move to parent directory \\[dired-up-directory] + move to first child subdirectory \\[dired-down-directory] + +Immediate Actions on Files + visit current file \\[dired-advertised-find-file] + visit current file in other window \\[dired-find-file-other-window] + visit current file in other frame %s + display current file \\[universal-argument] \\[dired-find-file-other-window] + create a new subdirectory \\[dired-create-directory] + recover file from auto-save \\[dired-recover-file] + +Marking & Unmarking Files + mark a file or subdirectory for later commands \\[dired-mark] + unmark a file or all files of a subdirectory \\[dired-unmark] + unmark all marked files in a buffer \\[dired-unmark-all-files] + count marks in buffer 0 \\[dired-unmark-all-files] + mark all directories \\[dired-mark-directories] + mark all executable files \\[dired-mark-executables] + mark file names matching a regular expression \\[dired-mark-files-regexp] + +Commands on Files Marked or Specified by the Prefix + rename a file or move files to another directory \\[dired-do-rename] + copy files \\[dired-do-copy] + delete marked (as opposed to flagged) files \\[dired-do-delete] + compress or uncompress files \\[dired-do-compress] + uuencode or uudecode files \\[dired-do-uucode] + grep files \\[dired-do-grep] + search for regular expression \\[dired-do-tags-search] + query replace by regular expression \\[dired-do-tags-query-replace] + byte-compile files \\[dired-do-byte-compile] + load files \\[dired-do-load] + shell command on files \\[dired-do-shell-command] + operate shell command separately on each file \\[universal-argument] \\[dired-do-shell-command] + do as above, but in each file's directory \\[universal-argument] \\[universal-argument] \\[dired-do-shell-command] + +Flagging Files for Deletion (unmark commands remove delete flags) + flag file for deletion \\[dired-flag-file-deletion] + backup and remove deletion flag \\[dired-backup-unflag] + flag all backup files (file names ending in ~) \\[dired-flag-backup-files] + flag all auto-save files \\[dired-flag-auto-save-files] + clean directory of numeric backups \\[dired-clean-directory] + execute the deletions requested (flagged files) \\[dired-expunge-deletions] + +Modifying the Dired Buffer + insert a subdirectory in this buffer \\[dired-maybe-insert-subdir] + removing a subdir listing \\[dired-kill-subdir] + relist single file, marked files, or subdir \\[dired-do-redisplay] + re-read all directories (retains all marks) \\[revert-buffer] + toggle sorting of current subdir by name/date \\[dired-sort-toggle-or-edit] + report on current ls switches 0 \\[dired-sort-toggle-or-edit] + edit ls switches for current subdir 1 \\[dired-sort-toggle-or-edit] + edit default ls switches for new subdirs 2 \\[dired-sort-toggle-or-edit] + sort all subdirs by name/date \\[universal-argument] \\[dired-sort-toggle-or-edit] + edit the ls switches for all subdirs \\[universal-argument] \\[universal-argument] \\[dired-sort-toggle-or-edit] + +Hiding File Lines + toggle file omission in current subdir \\[dired-omit-toggle] + kill marked file lines \\[dired-do-kill-file-lines] + +Help on Dired + dired help (what you're reading) \\[dired-describe-mode] + dired summary (short help) \\[dired-summary] + dired info (full dired info manual) \\[universal-argument] \\[dired-describe-mode] + apropos for dired commands \\[dired-apropos] + apropos for dired variables \\[universal-argument] \\[dired-apropos] + +Regular Expression Commands + mark files with a regular expression \\[dired-mark-files-regexp] + copy marked files by regexp \\[dired-do-copy-regexp] + rename marked files by regexp \\[dired-do-rename-regexp] + omit files by regexp \\[dired-omit-expunge] + downcase file names (rename to lowercase) \\[dired-downcase] + upcase files names (rename to uppercase) \\[dired-upcase] + +Comparing Files + diff file at point with file at mark \\[dired-diff] + diff file with its backup \\[dired-backup-diff] + merge file at point with file at mark \\[dired-emerge] + same as above but use a common ancestor \\[dired-emerge-with-ancestor] + ediff file at point with file at mark \\[dired-ediff] + patch file at point \\[dired-epatch] + +Mouse Commands +%s + +Miscellaneous + quit dired \\[dired-quit] + insert current directory in minibuffer \\[dired-get-target-directory] + +If the dired buffer gets confused, you can either type \\[revert-buffer] to read all +directories again, type \\[dired-do-redisplay] to relist a single file, the marked +files, or a subdirectory, or type \\[dired-build-subdir-alist] to parse +the directory tree in the buffer again. + +Customization Variables: +Use %s to obtain more information. + +%s + +Hook Variables: +Use %s to obtain more information. + +%s + +Keybindings: +\\{dired-mode-map}" + + ;; arguments to format + (if 18-p + "Unavailable in Emacs 18" + " \\[dired-find-file-other-frame]") + (if 18-p + " Unavailable in Emacs 18" + "\ + find file with mouse \\[dired-mouse-find-file] + mark file at mouse \\[dired-mouse-mark] + flag for deletion file at mouse \\[dired-mouse-flag] + menu of commands to visit a file \\[dired-visit-popup-menu] + menu of operations to do on a file \\[dired-do-popup-menu] + insert directory of mouse in minibuffer \\[dired-mouse-get-target] +") + var-help-key + (progn + (erase-buffer) + (dired-format-columns-of-files + (sort + (all-completions + "dired-" obarray + (function + (lambda (sym) + (and (user-variable-p sym) + (not (dired-hook-variable-p + sym)))))) + 'string<) t) + (buffer-string)) + var-help-key + (progn + (erase-buffer) + (dired-format-columns-of-files + (sort + (all-completions + "dired-" obarray + (function + (lambda (sym) + (dired-hook-variable-p sym)))) + 'string<) t) + (buffer-string))))) + (kill-buffer " dired-help-temp")))))) + +;;; Commands + +(defun dired-describe-mode (&optional info) + "Detailed description of dired mode. +With a prefix, runs the info documentation browser for dired." + (interactive "P") + ;; Getting dired documentation can be a bit slow. + (if info + (info "dired") + (message "Building dired help...") + (let* ((buff (get-buffer-create "*Help*")) + (standard-output buff) + (mess (dired-documentation))) + (message "Building dired help... done") + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (princ mess) + nil))) ; return nil so ehelp puts us at the top of the buffer. + (with-output-to-temp-buffer (buffer-name buff) + (princ mess) + (print-help-return-message)))))) + +(defun dired-apropos (string &optional var-p) + "Does command apropos for dired commands. +With prefix does apropos for dired variables." + (interactive + (list + (if current-prefix-arg + (read-string "Dired variable apropos (regexp): ") + (read-string "Dired command apropos (regexp): ")) + current-prefix-arg)) + (message "Doing dired %s apropos..." (if var-p "variable" "command")) + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (dired-apropos-internal string var-p) + nil))) + (with-output-to-temp-buffer "*Help*" + (dired-apropos-internal string var-p) + (or (print-help-return-message) + (message "Doing dired %s apropos...done" + (if var-p "variable" "command")))))) + +(defun dired-apropos-internal (string &optional var-p) + (let ((case-fold-search t) + (names (sort (all-completions "dired-" obarray + (if var-p + 'user-variable-p + 'commandp)) + 'string<)) + doc) + (mapcar + (function + (lambda (x) + (and (if var-p (user-variable-p (intern x)) (commandp (intern x))) + (progn + (setq doc (if var-p + (get (intern x) 'variable-documentation) + (documentation (intern x)))) + (and doc (setq doc (substring doc 0 (string-match "\n" doc)))) + (or (string-match string x) + (and doc (string-match string doc)))) + (progn + (princ x) + (if var-p (princ " :") + (princ " :") + (princ (make-string (max 2 (- 30 (length x))) ?\ )) + (princ (dired-help-key-description (intern x)))) + (princ "\n ") + (princ doc) + (princ "\n"))))) + names))) + +(defun dired-help-key-description (fun) + ;; Returns a help string of keys for fun. + (let ((res (mapconcat 'key-description + (where-is-internal fun dired-mode-map) ", "))) + (if (string-equal res "") + "\(not on any keys\)" + res))) + +(defun dired-summary () + "Display summary of basic dired commands in the minibuffer." + (interactive) + (let ((del (where-is-internal 'dired-flag-file-deletion dired-mode-map)) + (und (where-is-internal 'dired-unmark dired-mode-map)) + (exp (where-is-internal 'dired-expunge-deletions dired-mode-map)) + (fin (where-is-internal 'dired-advertised-find-file dired-mode-map)) + (oth (where-is-internal 'dired-find-file-other-window dired-mode-map)) + (ren (where-is-internal 'dired-do-rename dired-mode-map)) + (cop (where-is-internal 'dired-do-copy dired-mode-map)) + (hel (where-is-internal 'dired-describe-mode dired-mode-map))) + (if (member "d" del) + (setq del "d-elete") + (setq del (substitute-command-keys + "\\\\[dired-flag-file-deletion] delete"))) + (if (member "u" und) + (setq und "u-ndelete") + (setq und (substitute-command-keys + "\\\\[dired-unmark] undelete"))) + (if (member "x" exp) + (setq exp "x-punge") + (setq exp (substitute-command-keys + "\\\\[dired-expunge-deletions] expunge"))) + (if (member "f" fin) + (setq fin "f-ind") + (setq fin (substitute-command-keys + "\\\\[dired-advertised-find-file] find"))) + (if (member "o" oth) + (setq oth "o-ther window") + (setq oth + (substitute-command-keys + "\\\\[dired-find-file-other-window] other window") + )) + (if (member "R" ren) + (setq ren "R-ename") + (setq ren (substitute-command-keys + "\\\\[dired-do-rename] rename"))) + (if (member "C" cop) + (setq cop "C-opy") + (setq cop (substitute-command-keys + "\\\\[dired-do-copy] copy"))) + (if (member "h" hel) + (setq hel "h-elp") + (setq hel (substitute-command-keys + "\\\\[describe-mode] help"))) + (message "%s, %s, %s, %s. %s, %s, %s, %s" + del und exp fin oth ren cop hel))) + +(defun dired-hook-variable-p (sym) + ;; Returns t if SYM is a hook variable. Just looks at its name. + (let ((name (symbol-name sym))) + (and (>= (length name) 6) + (or (string-equal (substring name -5) "-hook") + (string-equal (substring name -6) "-hooks"))))) + +;;; Submitting bug reports. + +(defun dired-report-bug () + "Submit a bug report for dired." + (interactive) + (let ((reporter-prompt-for-summary-p t)) + (or (boundp 'reporter-version) + (setq reporter-version + "Your version of reporter is obsolete. Please upgrade.")) + (reporter-submit-bug-report + dired-bug-address "Dired" + (cons + 'dired-version + (nconc + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions "dired-" obarray 'user-variable-p)) + 'string-lessp)) + (list 'reporter-version))) + (function + (lambda () + (save-excursion + (mail-position-on-field "subject") + (beginning-of-line) + (skip-chars-forward "^:\n") + (if (looking-at ": Dired;") + (progn + (goto-char (match-end 0)) + (delete-char -1) + (insert " " dired-version " bug:"))))))))) + +;;; end of dired-help.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-mob.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-mob.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,122 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-mob.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Commands for marking files from another buffer. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-mob) +(require 'dired) +(autoload 'compilation-buffer-p "compile") +(autoload 'compile-reinitialize-errors "compile") + +;; For the byte-compiler +(defvar compilation-error-list) + +;;; Utilities + +(defun dired-mark-these-files (file-list from) + ;; Mark the files in FILE-LIST. Relative filenames are taken to be + ;; in the current dired directory. + ;; FROM is a string (used for logging) describing where FILE-LIST + ;; came from. + ;; Logs files that were not found and displays a success or failure + ;; message. + (message "Marking files %s..." from) + (let ((total (length file-list)) + (cur-dir (dired-current-directory)) + file failures) + (while file-list + (setq file (expand-file-name (car file-list) cur-dir) + file-list (cdr file-list)) + ;;(message "Marking file `%s'" file) + (save-excursion + (if (dired-goto-file file) + (dired-mark 1) ; supplying a prefix keeps it from checking + ; for a subdir. + (setq failures (cons (dired-make-relative file) failures)) + (dired-log (buffer-name (current-buffer)) + "Cannot mark this file (not found): %s\n" file)))) + (dired-update-mode-line-modified t) + (if failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "Failed to mark %d of %d files %s %s" + (length failures) total from failures) failures) + (message "Marked %d file%s %s." total (dired-plural-s total) from)))) + +;;; User commands + +(defun dired-mark-files-from-other-dired-buffer (buf) + "Mark files that are marked in the other Dired buffer. +I.e, mark those files in this Dired buffer that have the same +non-directory part as the marked files in the Dired buffer in the other +window." + (interactive (list (window-buffer (next-window)))) + (if (eq (get-buffer buf) (current-buffer)) + (error "Other dired buffer is the same")) + (or (stringp buf) (setq buf (buffer-name buf))) + (let ((other-files (save-excursion + (set-buffer buf) + (or (eq major-mode 'dired-mode) + (error "%s is not a dired buffer" buf)) + (dired-get-marked-files 'no-dir)))) + (dired-mark-these-files other-files (concat "from buffer " buf)))) + +(defun dired-mark-files-compilation-buffer (&optional buf) + "Mark the files mentioned in the `*compilation*' buffer. +With a prefix, you may specify the other buffer." + (interactive + (list + (let ((buff (let ((owin (selected-window)) + found) + (unwind-protect + (progn + (other-window 1) + (while (null (or found (eq (selected-window) owin))) + (if (compilation-buffer-p + (window-buffer (selected-window))) + (setq found (current-buffer))) + (other-window 1))) + (select-window owin)) + found))) + (if (or current-prefix-arg (null buff)) + (let ((minibuffer-history + (delq nil + (mapcar + (function + (lambda (b) + (and (compilation-buffer-p b) (buffer-name b)))) + (buffer-list))))) + (read-buffer "Use buffer: " + (or buff (car minibuffer-history)))) + buff)))) + (let ((dired-dir (directory-file-name default-directory)) + files) + (save-window-excursion + (set-buffer buf) + (compile-reinitialize-errors nil (point-max)) + (let ((alist compilation-error-list) + f d elt) + (while alist + (setq elt (car alist) + alist (cdr alist)) + (and (consp (setq elt (car (cdr elt)))) + (stringp (setq d (car elt))) + (stringp (setq f (cdr elt))) + (progn + (setq d (expand-file-name d)) + (dired-in-this-tree d dired-dir)) + (progn + (setq f (expand-file-name f d)) + (not (member f files))) + (setq files (cons f files)))))) + (dired-mark-these-files + files + (concat "From compilation buffer " + (if (stringp buf) buf (buffer-name buf)))))) + +;;; end of dired-mob.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-mule.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-mule.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,36 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-mule.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: MULE support for dired. +;; Created: Sun Jul 17 14:45:12 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Acknowledgements: +;; +;; Ishikawa Ichiro for sending MULE patches and information. + +(require 'dired) + +(defun dired-find-file (&optional coding-system) + "In dired, visit the file or directory named on this line." + (interactive "ZCoding-system: ") + (find-file (dired-get-filename) coding-system)) + +(defun dired-find-file-other-window (&optional display coding-system) + "In dired, visit this file or directory in another window. +With a prefix, the file is displayed, but the window is not selected." + (interactive "P\nZCoding-system: ") + (if display + (dired-display-file coding-system) + (find-file-other-window (dired-get-filename) coding-system))) + +(defun dired-display-file (&optional coding-system) + "In dired, displays this file or directory in the other window." + (interactive "ZCoding-system: ") + (display-buffer + (find-file-noselect (dired-get-filename) coding-system))) + +;;; end of dired-mule.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-oas.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-oas.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,58 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-oas.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired odds and sods. Dired functions not usually needed. +;; This file is not a reference to the Organization of +;; American States. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Don't require or provide anything, as this file is just an archive. + +(defun dired-sort-on-size () + "Sorts a dired listing on file size. +If your ls cannot sort on size, this is useful as `dired-after-readin-hook': + \(setq dired-after-readin-hook 'dired-sort-on-size\)" + (require 'sort) + (goto-char (point-min)) + (dired-goto-next-file) ; skip `total' line + (beginning-of-line) + (sort-subr t 'forward-line 'end-of-line 'dired-get-file-size)) + +(defun dired-directories-of (files) + ;; Return unique list of parent directories of FILES. + (let (dirs dir file) + (while files + (setq file (car files) + files (cdr files) + dir (file-name-directory file)) + (or (member dir dirs) + (setq dirs (cons dir dirs)))) + dirs)) + +(defun dired-parse-ls-show () + (interactive) + (let (inode s mode size uid gid nlink time name sym) + (if (dired-parse-ls) + (message "%s" (list inode s mode nlink uid gid size time name sym)) + (message "Not on a file line.")))) + +(defun dired-files-same-directory (file-list &optional absolute) + "If all files in LIST are in the same directory return it, otherwise nil. +Returned name has no trailing slash. \"Same\" means file-name-directory of +the files are string=. File names in LIST must all be absolute or all be +relative. Implicitly, relative file names are in default-directory. If +optional ABS is non-nil, the returned name will be absolute, otherwise the +returned name will be absolute or relative as per the files in LIST." + (let ((dir (file-name-directory (car file-list)))) + (if (memq nil (mapcar (function + (lambda (file) + (string= dir (file-name-directory file)))) + file-list)) + nil + (directory-file-name + (if (or (not absolute) (and dir (file-name-absolute-p dir))) + (or dir "") + (concat default-directory dir)))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-rgxp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-rgxp.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,267 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-rgxp.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for running commands on files whose names +;; match a regular expression. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-rgxp) +(require 'dired) + +;;; Variables + +(defvar dired-flagging-regexp nil) +;; Last regexp used to flag files. + +;;; Utility functions + +(defun dired-do-create-files-regexp + (file-creator operation arg regexp newname &optional whole-path marker-char) + ;; Create a new file for each marked file using regexps. + ;; FILE-CREATOR and OPERATION as in dired-create-files. + ;; ARG as in dired-get-marked-files. + ;; Matches each marked file against REGEXP and constructs the new + ;; filename from NEWNAME (like in function replace-match). + ;; Optional arg WHOLE-PATH means match/replace the whole pathname + ;; instead of only the non-directory part of the file. + ;; Optional arg MARKER-CHAR as in dired-create-files. + (let* ((fn-list (dired-get-marked-files nil arg)) + (name-constructor + (if whole-path + (list 'lambda '(from) + (list 'let + (list (list 'to + (list 'dired-string-replace-match + regexp 'from newname))) + (list 'or 'to + (list 'dired-log + '(buffer-name (current-buffer)) + "%s: %s did not match regexp %s\n" + operation 'from regexp)) + 'to)) + (list 'lambda '(from) + (list 'let + (list (list 'to + (list 'dired-string-replace-match regexp + '(file-name-nondirectory from) + newname))) + (list 'or 'to + (list 'dired-log '(buffer-name (current-buffer)) + "%s: %s did not match regexp %s\n" + operation '(file-name-nondirectory from) + regexp)) + '(and to + (expand-file-name + to (file-name-directory from))))))) + (operation-prompt (concat operation " `%s' to `%s'?")) + (rename-regexp-help-form (format "\ +Type SPC or `y' to %s one match, DEL or `n' to skip to next, +`!' to %s all remaining matches with no more questions." + (downcase operation) + (downcase operation))) + (query (list 'lambda '(from to) + (list 'let + (list (list 'help-form + rename-regexp-help-form)) + (list 'dired-query + '(quote dired-file-creator-query) + operation-prompt + '(dired-abbreviate-file-name from) + '(dired-abbreviate-file-name to)))))) + (dired-create-files + file-creator operation fn-list name-constructor marker-char query))) + +(defun dired-mark-read-regexp (operation) + ;; Prompt user about performing OPERATION. + ;; Read and return list of: regexp newname arg whole-path. + (let* ((whole-path + (equal 0 (prefix-numeric-value current-prefix-arg))) + (arg + (if whole-path nil current-prefix-arg)) + (regexp + (dired-read-with-history + (concat (if whole-path "Path " "") operation " from (regexp): ") + dired-flagging-regexp 'dired-regexp-history)) + (newname + (read-string + (concat (if whole-path "Path " "") operation " " regexp " to: ") + (and (not whole-path) (dired-dwim-target-directory))))) + (list regexp newname arg whole-path))) + +;;; Marking file names matching a regexp. + +(defun dired-mark-files-regexp (regexp &optional marker-char omission-files-p) + "\\Mark all files matching REGEXP for use in later commands. + +A prefix argument \\[universal-argument] means to unmark them instead. + +A prefix argument 0 means to mark the files that would me omitted by \\[dired-omit-toggle]. +A prefix argument 1 means to unmark the files that would be omitted by \\[dired-omit-toggle]. + +REGEXP is an Emacs regexp, not a shell wildcard. Thus, use \"\\.o$\" for +object files--just `.o' will mark more than you might think. The files \".\" +and \"..\" are never marked. +" + (interactive + (let ((unmark (and (not (eq current-prefix-arg 0)) current-prefix-arg)) + (om-files-p (memq current-prefix-arg '(0 1))) + regexp) + (if om-files-p + (setq regexp (dired-omit-regexp)) + (setq regexp (dired-read-with-history + (concat (if unmark "Unmark" "Mark") + " files (regexp): ") nil + 'dired-regexp-history))) + (list regexp (if unmark ?\ ) om-files-p))) + (let ((dired-marker-char (or marker-char dired-marker-char))) + (dired-mark-if + (and (not (looking-at dired-re-dot)) + (not (eolp)) ; empty line + (let ((fn (dired-get-filename nil t))) + (and fn (string-match regexp (file-name-nondirectory fn))))) + (if omission-files-p + "omission candidate file" + "matching file")))) + +(defun dired-flag-files-regexp (regexp) + "In dired, flag all files containing the specified REGEXP for deletion. +The match is against the non-directory part of the filename. Use `^' + and `$' to anchor matches. Exclude subdirs by hiding them. +`.' and `..' are never flagged." + (interactive (list (dired-read-with-history + "Flag for deletion (regexp): " nil + 'dired-regexp-history))) + (dired-mark-files-regexp regexp dired-del-marker)) + +(defun dired-mark-extension (extension &optional marker-char) + "Mark all files with a certain extension for use in later commands. +A `.' is not prepended to the string entered." + ;; EXTENSION may also be a list of extensions instead of a single one. + ;; Optional MARKER-CHAR is marker to use. + (interactive "sMark files with extension: \nP") + (or (listp extension) + (setq extension (list extension))) + (dired-mark-files-regexp + (concat ".";; don't match names with nothing but an extension + "\\(" + (mapconcat 'regexp-quote extension "\\|") + "\\)$") + marker-char)) + +(defun dired-flag-extension (extension) + "In dired, flag all files with a certain extension for deletion. +A `.' is not prepended to the string entered." + (interactive "sFlag files with extension: ") + (dired-mark-extension extension dired-del-marker)) + +(defun dired-cleanup (program) + "Flag for deletion dispensable files created by PROGRAM. +See variable `dired-cleanup-alist'." + (interactive + (list + (let ((dired-cleanup-history (append dired-cleanup-history + (mapcar 'car dired-cleanup-alist)))) + (dired-completing-read + "Cleanup files for: " dired-cleanup-alist nil t nil + 'dired-cleanup-history)))) + (dired-flag-extension (cdr (assoc program dired-cleanup-alist)))) + +;;; Commands on marked files whose names also match a regexp. + +(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) + "Rename marked files containing REGEXP to NEWNAME. +As each match is found, the user must type a character saying + what to do with it. For directions, type \\[help-command] at that time. +NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. +REGEXP defaults to the last regexp used. +With a zero prefix arg, renaming by regexp affects the complete + pathname - usually only the non-directory part of file names is used + and changed." + (interactive (dired-mark-read-regexp "Rename")) + (dired-do-create-files-regexp + (function dired-rename-file) + "Rename" arg regexp newname whole-path dired-keep-marker-rename)) + +(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) + "Copy all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "Copy")) + (dired-do-create-files-regexp + (function dired-copy-file) + (if dired-copy-preserve-time "Copy [-p]" "Copy") + arg regexp newname whole-path dired-keep-marker-copy)) + +(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) + "Hardlink all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "HardLink")) + (dired-do-create-files-regexp + (function add-name-to-file) + "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) + +(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) + "Symlink all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "SymLink")) + (dired-do-create-files-regexp + (function make-symbolic-link) + "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) + +(defun dired-do-relsymlink-regexp (regexp newname &optional whole-path) + "RelSymlink all marked files containing REGEXP to NEWNAME. +See functions `dired-rename-regexp' and `dired-do-relsymlink' + for more info." + (interactive (dired-mark-read-regexp "RelSymLink")) + (dired-do-create-files-regexp + (function dired-make-relative-symlink) + "RelSymLink" nil regexp newname whole-path dired-keep-marker-symlink)) + +;;;; Modifying the case of file names. + +(defun dired-create-files-non-directory + (file-creator basename-constructor operation arg) + ;; Perform FILE-CREATOR on the non-directory part of marked files + ;; using function BASENAME-CONSTRUCTOR, with query for each file. + ;; OPERATION like in dired-create-files, ARG like in dired-get-marked-files. + (let (rename-non-directory-query) + (dired-create-files + file-creator + operation + (dired-get-marked-files nil arg) + (function + (lambda (from) + (let ((to (concat (file-name-directory from) + (funcall basename-constructor + (file-name-nondirectory from))))) + (and (let ((help-form (format "\ +Type SPC or `y' to %s one file, DEL or `n' to skip to next, +`!' to %s all remaining matches with no more questions." + (downcase operation) + (downcase operation)))) + (dired-query 'rename-non-directory-query + (concat operation " `%s' to `%s'") + (dired-make-relative from) + (dired-make-relative to))) + to)))) + dired-keep-marker-rename))) + +(defun dired-rename-non-directory (basename-constructor operation arg) + (dired-create-files-non-directory + (function dired-rename-file) + basename-constructor operation arg)) + +(defun dired-upcase (&optional arg) + "Rename all marked (or next ARG) files to upper case." + (interactive "P") + (dired-rename-non-directory (function upcase) "Rename upcase" arg)) + +(defun dired-downcase (&optional arg) + "Rename all marked (or next ARG) files to lower case." + (interactive "P") + (dired-rename-non-directory (function downcase) "Rename downcase" arg)) + +;;; end of dired-rgxp.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-sex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-sex.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,156 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-sex.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Marking files according to sexpressions. Sorry. +;; Created: Wed Sep 14 01:30:43 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'dired-sex) +(require 'dired) + +(defvar dired-sexpr-history-symbol nil + "History of sexpr used to mark files in dired.") + +;;; Marking files according to sexpr's + +(defmacro dired-parse-ls () + ;; Sets vars + ;; inode s mode nlink uid gid size time name sym + ;; (probably let-bound in caller) according to current file line. + ;; Returns t for succes, nil if this is no file line. + ;; Upon success, all variables are set, either to nil or the + ;; appropriate value, so they need not be initialized. + ;; Moves point within the current line to the end of the file name. + '(let ((bol (progn (beginning-of-line) (point))) + (eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if (re-search-forward dired-re-month-and-time eol t) + (let ((mode-len 10) ; length of mode string + (tstart (progn (goto-char (match-beginning 0)) + (skip-chars-forward " ") + (point))) + (fstart (match-end 0)) + pos) + (goto-char (1+ bol)) + (skip-chars-forward " \t") + ;; This subdir had better have been created with the current + ;; setting of actual switches. Otherwise, we can't parse. + (cond + ((and (or (memq ?k dired-internal-switches) + (memq ?s dired-internal-switches)) + (memq ?i dired-internal-switches)) + (setq pos (point)) + (skip-chars-forward "0-9") + (if (setq inode (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point))))) + (progn + (skip-chars-forward " ") + (setq pos (point)) + (skip-chars-forward "0-9") + (setq s (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))))) + (setq s nil))) + ((or (memq ?s dired-internal-switches) + (memq ?k dired-internal-switches)) + (setq pos (point)) + (skip-chars-forward "0-9") + (setq s (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))) + inode nil)) + ((memq ?i dired-internal-switches) + (setq pos (point)) + (skip-chars-forward "0-9") + (setq inode (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))) + s nil)) + (t + (setq s nil + inode nil))) + (skip-chars-forward " 0-9") ; in case of junk + (setq mode (buffer-substring (point) (+ mode-len (point)))) + (forward-char mode-len) + (setq nlink (read (current-buffer))) + (or (integerp nlink) (setq nlink nil)) + (setq uid (buffer-substring (point) (progn + (skip-chars-forward "^ ") + (point)))) + (goto-char tstart) + (skip-chars-backward " ") + (setq pos (point)) + (skip-chars-backward "0-9") + (if (= pos (point)) + (setq size nil) + (setq size (string-to-int (buffer-substring (point) pos)))) + (skip-chars-backward " ") + ;; if no gid is displayed, gid will be set to uid + ;; but user will then not reference it anyway in PREDICATE. + (setq gid (buffer-substring (point) (progn + (skip-chars-backward "^ ") + (point))) + time (buffer-substring tstart + (progn + (goto-char fstart) + (skip-chars-backward " ") + (point))) + name (buffer-substring + fstart + (or (dired-move-to-end-of-filename t) + (point))) + sym (and (looking-at "[/*@#=|]? -> ") + (buffer-substring (match-end 0) + eol))) + t)))) ; return t if parsing was a success + + +(defun dired-mark-sexp (predicate &optional unflag-p) + "Mark files for which PREDICATE returns non-nil. +With a prefix arg, unflag those files instead. + +PREDICATE is a lisp expression that can refer to the following symbols: + + inode [integer] the inode of the file (only for ls -i output) + s [integer] the size of the file for ls -s output + (ususally in blocks or, with -k, in KByte) + mode [string] file permission bits, e.g. \"-rw-r--r--\" + nlink [integer] number of links to file + uid [string] owner + gid [string] group (If the gid is not displayed by ls, + this will still be set (to the same as uid)) + size [integer] file size in bytes + time [string] the time that ls displays, e.g. \"Feb 12 14:17\" + name [string] the name of the file + sym [string] if file is a symbolic link, the linked-to name, else nil. + +For example, use + + (equal 0 size) + +to mark all zero length files." + ;; Using sym="" instead of nil avoids the trap of + ;; (string-match "foo" sym) into which a user would soon fall. + ;; No! Want to be able look for symlinks pointing to the empty string. + ;; Can happen. Also, then I can do an (if sym ...) structure. --sandy + ;; Give `equal' instead of `=' in the example, as this works on + ;; integers and strings. + (interactive + (list + (read + (dired-read-with-history "Mark if (lisp expr): " nil + 'dired-sexpr-history)) + current-prefix-arg)) + (message "%s" predicate) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) + inode s mode nlink uid gid size time name sym) + (dired-mark-if (save-excursion + (and (dired-parse-ls) + (eval predicate))) + (format "'%s file" predicate))) + (dired-update-mode-line-modified t)) + +;;; end of dired-sex.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-shell.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-shell.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,854 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-shell.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for running shell commands on marked files. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-shell) +(require 'dired) +(autoload 'comint-mode "comint") + +;;; Variables + +(defvar dired-postscript-print-command + (concat + (if (boundp 'lpr-command) + lpr-command + (if (memq system-type + '(usg-unix-v hpux silicon-graphics-unix)) + "lp" + "lpr")) + (if (and (boundp 'lpr-switches) lpr-switches) + (concat " " + (mapconcat 'identity lpr-switches " ") + " ") + " ")) + "Command to print a postscript file.") + +(defvar dired-text-print-command (concat dired-postscript-print-command " -p") + "Command to print a text file.") + +(defvar dired-print-program-alist + (list + (cons "\\.gif$" (concat "giftoppm * | ppmtopgm | pnmtops | " + dired-postscript-print-command)) + (cons "\\.\\(fts\\|FTS\\)$" (concat "fitstopgm * | pnmtops | " + dired-postscript-print-command)) + ;; People with colour printers won't want the g-flag in djpeg + (cons "\\.\\(JPG\\|jpg\\)$" (concat "djpeg -Pg * | pnmtops | " + dired-postscript-print-command)) + (cons "\\.ps\\.\\(gz\\|Z\\)$" (concat "zcat * | " + dired-postscript-print-command)) + (cons "\\.ps$" dired-postscript-print-command) + (cons "\\.\\(gz\\|Z\\)$" (concat "zcat * | " + dired-postscript-print-command)) + (cons "\\.dvi$" "dvips") + (cons ".*" dired-text-print-command)) + "Alist of regexps and print commands. +This is used by `dired-do-print' to determine the default print command for +printing the marked files.") + +(defvar dired-auto-shell-command-alist nil + "*Alist of regexps and command lists to guess shell commands. +Each element of this list should be a list of regular expression, and a list +of guesses for shell commands to be used if the file name matches the regular +expression. The list of guesses is evalled. This alist is appended to the front +of dired-default-auto-shell-command-alist before prompting for each shell +command.") + +(defvar dired-default-auto-shell-command-alist + (list + + ;; Archiving + '("\\.tar$" + (if dired-gnutar-program + (concat dired-gnutar-program " xvf") + "tar xvf") + (if dired-gnutar-program + (concat dired-gnutar-program " tvf") + "tar tvf")) + ;; regexps for compressed archives must come before the .Z rule to + ;; be recognized: + '("\\.tar\\.\\([zZ]\\|gz\\)\\|\\.tgz$" ; .tgz is for DOS + (if dired-gnutar-program + (concat dired-gnutar-program " zxvf") + "zcat * | tar xvf -") + (if dired-gnutar-program + (concat dired-gnutar-program " ztvf") + "zcat * | tar tvf -")) + '("\\.shar.[zZ]$" (if dired-unshar-program + (concat "zcat * | " dired-unshar-program) + "zcat * | sh")) + '("\\.zoo$" "zoo x//") + '("\\.zip$" "unzip" "unzip -v") + '("\\.lzh$" "lharc x") + '("\\.arc$" "arc x") + '("\\.shar$" (if dired-unshar-program dired-unshar-program "sh")) + + ;; Encoding/compressing + '("\\.uu$" "uudecode") + '("\\.hqx$" "mcvert") + + ;; Executing (in the generalized sense) + '("\\.sh$" "sh") ; execute shell scripts + '("^[Mm]akefile$" "make -f *") + '("\\.diff$" "patch -t <") + + ;; Displaying (assumes X) + '("\\.xbm$" "bitmap") ; view X11 bitmaps + '("\\.gp$" "gnuplot") + '("\\.gif$" "xv") ; view gif pictures + '("\\.fig$" "xfig") ; edit fig pictures + '("\\.ps$" "ghostview") + + ;; Typesetting. For printing documents, see dired-print-program-alist. + '("\\.tex$" "latex" "tex") + '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") + (if (eq window-system 'x) + (if dired-use-file-transformers + '("\\.dvi$" "xdvi" "dvips -o *b.ps *") + '("\\.dvi$" "xdvi" "dvips")) + (if dired-use-file-transformers + '("\\.dvi$" "dvips -o *b.ps *") + '("\\.dvi$" "dvips"))) + + ;; The last word. Things that cannot be grokked with a regexp. + '("." (if (> (length files) 1) + "tar cvf " + (and (= (length files) 1) (file-directory-p + (expand-file-name + (car files) + (dired-current-directory))) + (concat "tar cvf " (file-name-nondirectory + (directory-file-name (car files))) + ".tar")))) + ) + "Default for variable `dired-auto-shell-command-alist' (which see). +Set this to nil to turn off shell command guessing.") + +;; Might use {,} for bash or csh: +(defvar dired-shell-prefix "" + "Prepended to marked files in dired shell commands.") +(defvar dired-shell-postfix "" + "Appended to marked files in dired shell commands.") +(defvar dired-shell-separator " " + "Separates marked files in dired shell commands.") + +(defvar dired-file-wildcard ?* + "Wildcard character used by dired shell commands. +Indicates where file names should be inserted.") + +(defvar dired-shell-command-separators '(?\ ?| ?> ?< ?& ?;) + "Defines the start of a string specifying a word in a shell command.") + +(defvar dired-trans-map + (list + (cons ?f 'identity) + (cons ?n 'file-name-nondirectory) + (cons ?d 'file-name-directory) + (cons ?b 'dired-file-name-base) + (cons ?e 'dired-file-name-extension) + (cons ?v 'dired-file-name-sans-rcs-extension) + (cons ?z 'dired-file-name-sans-compress-extension)) + "Alist that associates keys with file transformer functions +Each transformer function should be a funcion of one argument, the file name. +The keys are characters.") + +(defvar dired-shell-failure-marker ?! + "*A marker to mark files on which shell commands fail. +If nil, such files are not marked.") + +;;; Internal variables + +;; Make sure this gets defined. +(defvar shell-command-history nil + "History list of previous shell commands.") + +(defvar dired-print-history nil + "History of commands used to print files.") + +(defvar dired-shell-input-start) ; only defined in shell output buffers + +;;; Utility functions and Macros + +(defun dired-shell-quote (filename) + ;; Quote a file name for inferior shell (see variable shell-file-name). + ;; Quote everything except POSIX filename characters. + ;; This should be safe enough even for really wierd shells. + (let ((result "") (start 0) end) + (while (string-match "[^---0-9a-zA-Z_./]" filename start) + (setq end (match-beginning 0) + result (concat result (substring filename start end) + "\\" (substring filename end (1+ end))) + start (1+ end))) + (concat result (substring filename start)))) + +(defun dired-uniquefy-list (list) + ;; Returns list, after removing 2nd and higher occurrences + ;; of all elements. Tests elements with equal. Retains the relative + ;; order of the elements. + ;; For small lists, this way is probably faster than sorting. + (let (result) + (while list + (or (member (car list) result) + (setq result (nconc result (list (car list))))) + (setq list (cdr list))) + result)) + +(defun dired-read-shell-command (prompt arg files) + ;; Read a dired shell command prompting with PROMPT (using read-string). + ;; ARG is the prefix arg and may be used to indicate in the prompt which + ;; files are affected. + (dired-mark-pop-up + nil 'shell files + (function + (lambda (prompt files) + (let* ((default (car shell-command-history)) + (guesses (dired-guess-default files)) + (len (length guesses)) + cmd) + (or (zerop len) + (setq prompt (format "%s{%d guess%s} " + prompt len (if (= len 1) "" "es")))) + (if default (setq prompt (concat prompt "[" default "] "))) + (put 'guesses 'no-default t) ; for gmhist, in case. + (setq guesses (nconc guesses (copy-sequence shell-command-history)) + cmd (dired-read-with-history prompt nil 'guesses)) + (if (string-match "^[ \t\n]*$" cmd) + (if default + (setq cmd default) + (error "No shell command given."))) + (setq shell-command-history + (dired-uniquefy-list + (cons cmd shell-command-history))) + cmd))) + (format prompt (dired-mark-prompt arg files)) files)) + +(defmacro dired-trans-subst (transformers filename dir) +;; Applies each transformer supplied in the string TRANSFORMERS in sequence +;; to FILE and returns the concatenation of the results. Also unquotes \\'s. +;; Returns a string if no file transformations were done, otherwise a list +;; consisting of a single string. + (` (let* ((transformers (, transformers)) + (filename (, filename)) + (len (length transformers)) + (pos 0) + (last 0) + (transformed nil) + (quoted nil) + char result trans) + (while (< pos len) + (setq char (aref transformers pos)) + (cond + (quoted (setq pos (1+ pos) + quoted nil)) + ((= ?\\ char) + (setq quoted t + result (concat result (substring transformers last pos)) + pos (1+ pos) + last pos)) + ((and (null quoted) (= char dired-file-wildcard)) + (setq pos (1+ pos) + trans (and (< pos len) + dired-use-file-transformers + (assq (aref transformers pos) + dired-trans-map)) + transformed t) + (if trans + (setq result (concat result + (substring transformers last (1- pos)) + (funcall (cdr trans) filename)) + pos (1+ pos) + last pos) + (setq result (concat result (substring transformers last (1- pos)) + (dired-make-relative filename (, dir) t)) + last pos))) + ((setq pos (1+ pos))))) + (if result + (progn + (setq result (dired-shell-quote + (concat result (substring transformers last)))) + (if transformed (list result) result)) + transformers)))) + +(defun dired-trans-filenames (transformers files dir) + ;; Applies a transformer string to a list of filenames, + ;; concatenating them into a string. The result will be prefixed + ;; by dired-shell-prefix, the filenames separated by dired-shell-separator, + ;; and postfixed by dired-shell-postfix. + ;; Returns a list if filename subst. was done. A string otherwise. + (let ((list files) + (res nil) + trans) + (while list + (setq trans (dired-trans-subst transformers (car list) dir)) + (if (listp trans) + (setq res (nconc res trans) + list (cdr list)) + (setq res trans + list nil))) + (if (listp res) + (list + (if (> (length files) 1) + (concat dired-shell-prefix + (mapconcat 'identity res dired-shell-separator) + dired-shell-postfix) + (car res))) + res))) + +(defun dired-trans-command (command files dir) + ;; Do all of the trans substitutions in COMMAND for the list + ;; of files FILES. FILES must be a list of *absolute* pathnames. + ;; DIR is an absolute directory wrto which filenames may be relativized. + (let ((len (length command)) + (start 0) + (pos 0) + (last 0) + result char transed transform) + (while (< pos len) + ;; read over word separators. + (while (and (< pos len) (memq (aref command pos) + dired-shell-command-separators)) + (setq pos (1+ pos))) + (setq start pos) + ;; read a word + (while (and (< pos len) (not (memq (setq char (aref command pos)) + dired-shell-command-separators))) + (setq pos (1+ pos)) + ;; look out for quoted separators + (and (= ?\\ char) (< pos len) (or (memq (setq char (aref command pos)) + dired-shell-command-separators) + (= ?\\ char)) + (setq pos (1+ pos)))) + (setq transform (if (= start pos) + "" + (dired-trans-filenames (substring command start pos) + files dir)) + ;; remember if we did any transforming + transed (or transed (listp transform)) + result (concat result + (substring command last start) + (if (listp transform) + (car transform) + transform)) + last pos)) + (if transed + ;; just return result + result + ;; add the filenames at the end. + (let ((fns (if (> (length files) 1) + (concat dired-shell-prefix + (mapconcat + (function + (lambda (fn) + (dired-shell-quote + (dired-make-relative fn dir t)))) + files dired-shell-separator) + dired-shell-postfix) + (dired-shell-quote + (dired-make-relative (car files) dir t))))) + (concat result " " fns))))) + +(defun dired-shell-stuff-it (command file-list dir on-each) + ;; Make up a shell command line from COMMAND and FILE-LIST. + ;; If ON-EACH is t, COMMAND should be applied to each file, else + ;; simply concat all files and apply COMMAND to this. + ;; If ON-EACH is 'dir, the command is run in the directory of each file + ;; In this case FILE-LIST must be a list of full paths. + ;; FILE-LIST's elements will be quoted for the shell. + (cond + ((eq on-each 'dir) + (let ((subshell-dir nil) + (list file-list) + (result nil)) + (while list + (let ((cmd (dired-trans-command command (list (car list)) + (file-name-directory (car list)))) + (fdir (dired-shell-quote (file-name-directory (car list))))) + (setq result + (apply 'concat + result + (if subshell-dir + (if (string-equal dir subshell-dir) + (list "\; " cmd) + (if (string-equal dir fdir) + (progn + (setq subshell-dir nil) + (list "\)\; " cmd)) + (setq subshell-dir fdir) + (list "\)\; \(cd " + fdir + "\; " + cmd))) + (if (string-equal fdir dir) + (list (and result "\; ") + cmd) + (setq subshell-dir fdir) + (list (and result "\; ") + "\(cd " + fdir + "\; " + cmd))))) + (setq list (cdr list)))) + (concat result (and subshell-dir ")")))) + (on-each + (mapconcat (function + (lambda (fn) + (dired-trans-command command (list fn) dir))) + file-list "; ")) + + (t (dired-trans-command command file-list dir)))) + +(defun dired-guess-default (files) + ;; Guess a list of possible shell commands for FILES. + (and dired-default-auto-shell-command-alist + files + (let ((alist (append dired-auto-shell-command-alist + dired-default-auto-shell-command-alist)) + guesses) + (while alist + (let* ((elt (car alist)) + (regexp (car elt))) + (setq guesses + (nconc guesses + (catch 'missed + (mapcar (function + (lambda (file) + (or (string-match regexp file) + (throw 'missed nil)))) + files) + (delq nil (mapcar 'eval (cdr elt))))))) + (setq alist (cdr alist))) + (dired-uniquefy-list guesses)))) + +(defun dired-shell-unhandle-file-name (filename) + "Turn a file name into a form that can be sent to a shell process. +This is particularly usefull if we are sending file names to a remote shell." + (let ((handler (find-file-name-handler filename 'dired-shell-unhandle-file-name))) + (if handler + (funcall handler 'dired-shell-unhandle-file-name filename) + filename))) + +;;; Actually running the shell command + +(defun dired-run-shell-command-closeout (buffer &optional message) + ;; Report on the number of lines produced by a shell command. + (if (get-buffer buffer) + (save-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (progn + (if message + (message "Shell command completed with no output. %s" + message) + (message "Shell command completed with no output.")) + (kill-buffer buffer)) + (set-window-start (display-buffer buffer) 1) + (if message + (message "Shell command completed. %s" message) + (message "Shell command completed.")))))) + +(defun dired-rsc-filter (proc string) + ;; Do save-excursion by hand so that we can leave point + ;; numerically unchanged despite an insertion immediately + ;; after it. + (let* ((obuf (current-buffer)) + (buffer (process-buffer proc)) + opoint + (window (get-buffer-window buffer)) + (pos (window-start window))) + (unwind-protect + (progn + (set-buffer buffer) + (setq opoint (point)) + (goto-char (point-max)) + (insert-before-markers string)) + ;; insert-before-markers moved this marker: set it back. + (set-window-start window pos) + ;; Finish our save-excursion. + (goto-char opoint) + (set-buffer obuf)))) + +(defun dired-rsc-sentinel (process signal) + ;; Sentinel function used by dired-run-shell-command + (if (memq (process-status process) '(exit signal)) + (let ((buffer (get-buffer (process-buffer process)))) + (if buffer + (save-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (message + "Dired & shell command completed with no output.") + (let ((lines (count-lines dired-shell-input-start + (point-max)))) + (message + "Dired & shell command completed with %d line%s of output." + lines (dired-plural-s lines)))) + (setq mode-line-process nil))) + (delete-process process)))) + +(defun dired-shell-call-process (command dir &optional in-background) + ;; Call a shell command as a process in the current buffer. + ;; The process should try to run in DIR. DIR is also + ;; used to lookup a file-name-handler. + ;; Must return the process object if IN-BACKGROUND is non-nil, + ;; otherwise the process exit status. + (let ((handler (find-file-name-handler dir 'dired-shell-call-process))) + (if handler + (funcall handler 'dired-shell-call-process command dir in-background) + (let ((process-connection-type ; don't waste pty's + (null (null in-background)))) + (setq default-directory dir) + (if in-background + (progn + (setq mode-line-process '(": %s")) + (start-process "Shell" (current-buffer) + shell-file-name "-c" command)) + (call-process shell-file-name nil t nil "-c" command)))))) + +(defun dired-run-shell-command (command dir in-background &optional append) + ;; COMMAND is shell command + ;; DIR is directory in which to do the shell command. + ;; If IN-BACKGROUND is non-nil, the shell command is run in the background. + ;; If it is a string, this is written as header into the output buffer + ;; before the command is run. + ;; If APPEND is non-nil, the results are appended to the contents + ;; of *shell-command* buffer, without erasing its previous contents. + (save-excursion + (if in-background + (let* ((buffer (get-buffer-create + "*Background Shell Command Output*")) + (n 2) + proc) + ;; No reason why we can't run two+ background commands. + (while (get-buffer-process buffer) + (setq buffer (get-buffer-create + (concat "*Background Shell Command Output*<" + (int-to-string n) ">")) + n (1+ n))) + (set-buffer buffer) + (or (eq major-mode 'comint-mode) + (progn + (comint-mode) + (set (make-local-variable 'comint-prompt-regexp) + "^[^\n]*\\? *"))) + (display-buffer buffer) + (barf-if-buffer-read-only) + ;; If will kill a process, query first. + + (set (make-local-variable 'dired-shell-input-start) (point-min)) + (if append + (progn + (goto-char (point-max)) + (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) + (erase-buffer) + (if (stringp in-background) + (progn + (insert in-background) + (set (make-local-variable 'dired-shell-input-start) + (point))))) + (setq proc (dired-shell-call-process command dir t)) + (set-marker (process-mark proc) (point)) + (set-process-sentinel proc 'dired-rsc-sentinel) + (set-process-filter proc 'dired-rsc-filter) + nil) ; return + (let ((buffer (get-buffer-create "*Shell Command Output*"))) + (set-buffer buffer) + (barf-if-buffer-read-only) + (set (make-local-variable 'dired-shell-input-start) (point-min)) + (if append + (progn + (goto-char (point-max)) + (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) + (erase-buffer)) + (dired-shell-call-process command dir))))) + +;;; User commands + +(defun dired-do-shell-command (command arg files &optional in-background) + ;; ARG = (16) means operate on each file, in its own directory. + ;; ARG = (4) means operate on each file, but in the current + ;; default-directory. + "Run a shell command COMMAND on the marked files. +If no files are marked or a non-zero numeric prefix arg is given, +the next ARG files are used. Use prefix 1 to indicate the current file. + +Normally the shell command is executed in the current dired subdirectory. +This is the directory in the dired buffer which currently contains the point. +One shell command is run for all of the files. +e.g. cmd file1 file2 file3 ... +If the total length of of the command exceeds 10000 characters, the files will +be bunched to forms commands shorter than this length, and successive commands +will be sent. + +With a prefix of \\[universal-argument], a separate command for each file will +be executed. + +With a prefix of \\[universal-argument] \\[universal-argument], a separate command will be sent for each file, +and the command will be executed in the directory of that file. The explicit +command will be of the form + + cd dir; cmd file + +When prompting for the shell command, dired will always indicate the directory +in which the command will be executed. + +The following documentation depends on the settings of `dired-file-wildcard', +`dired-shell-command-separators', `dired-trans-map', `dired-shell-prefix', +`dired-shell-separator', and `dired-shell-postfix'. See the documentation for +these variables. Below, I will assume default settings for these variables. + +If the shell command contains a *, then the list of files is substituted for *. +The filenames will be written as relative to the directory in which the shell +command is executing. If there is no *, and the command does not end in &, +then the files are appended to the end of the command. If the command ends in +a &, then the files are inserted before the &. + +If `dired-use-file-transformers' is non-nil, then certain 2-character +sequences represent parts of the file name. +The default transformers are: +*f = full file name +*n = file name without directory +*d = file name's directory + This will end in a \"/\" in unix. +*e = file names extension + By default this the part of the file name without directory, which + proceeds the first \".\". If \".\" is the first character of the name, + then this \".\" is ignored. The definition of extension can + be customized with `dired-filename-re-ext'. +*b = file base name + This is the part of the file name without directory that precedes + the extension. +*v = file name with out version control extension (i.e. \",v\") +*z = file name without compression extension + (i.e. \".Z\", \".z\", or \".gz\") + +Shell commands are divided into words separated by spaces. Then for each +word the file name transformers are applied to the list of files, the result +concatenated together and substituted for the word in the shell command. + +For example + cmd -a *f -b *d*b.fizzle applied to /foo/bar and /la/di/da results in + cmd -a /foo/bar /la/di/da -b /foo/bar.fizzle /la/di/da.fizzle + +The \"on-each\" prefixes \\[universal-argument] and 0, also apply while +using file transformers. As well, when using file-transformers * still +represents the file name relative to the current directory. Not that this +differs from *f, which always represents the full pathname. + +A \"\\\" can always be used to quote any character having special meaning. +For example, if the current directory is /la, then *n applied +to /la/di/da returns la, whereas *\\n returns di/dan. Similarly, +\"*d\\ *n\" returns \"/la/di da\". + +The prefix character for file name transformers is always the same as +`dired-file-wildcard'." + + (interactive + (let ((on-each (or (equal '(4) current-prefix-arg) + (equal '(16) current-prefix-arg))) + (files (dired-get-marked-files + nil (and (not (consp current-prefix-arg)) + current-prefix-arg))) + (dir (and (not (equal current-prefix-arg '(16))) + (dired-current-directory)))) + (list + (dired-read-shell-command + (concat (if dir + (format "! in %s" (dired-abbreviate-file-name dir)) + "cd ; ! ") + "on " + (if on-each "each ") + "%s: ") + (and (not on-each) current-prefix-arg) + (if dir + (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files) + files)) + current-prefix-arg files nil))) + + ;; Check for background commands + (if (string-match "[ \t]*&[ \t]*$" command) + (setq command (substring command 0 (match-beginning 0)) + in-background t)) + + ;; Look out for remote file names. + + (let* ((on-each (or (equal arg '(4)) (and (equal arg '(16)) 'dir))) + (ufiles (mapcar 'dired-shell-unhandle-file-name files)) + (dir (dired-current-directory)) + (udir (dired-shell-unhandle-file-name dir))) + + (save-excursion ; in case `shell-command' changes buffer + (cond + + ((null ufiles) + ;; Just run as a command on no files. + (if in-background + (dired-run-shell-command command dir t) + (dired-run-shell-command command dir nil) + (dired-run-shell-command-closeout "*Shell Command Output*"))) + + (in-background + ;; Can't use dired-bunch-files for background shell commands. + ;; as we will create a bunch of process running simultaneously. + ;; A better solution needs to be found. + (dired-run-shell-command + (dired-shell-stuff-it command ufiles udir on-each) + dir (if (equal arg '(16)) + (concat "cd ; \"" command "\"\n\n") + (concat "\"" command "\" in " dir "\n\n")))) + (on-each + (let ((buff (get-buffer "*Shell Command Output*")) + failures this-command this-dir ufile return message) + (if buff + (save-excursion + (set-buffer buff) + (erase-buffer))) + (while ufiles + (setq ufile (car ufiles)) + (if (eq on-each 'dir) + (setq this-dir (dired-shell-quote (file-name-directory (directory-file-name ufile))) + this-command (concat "cd " this-dir "; " command)) + (setq this-command command) + (or this-dir (setq this-dir udir))) + (setq return + (dired-run-shell-command + (dired-shell-stuff-it this-command (list ufile) this-dir nil) + this-dir nil t)) + (if (and (integerp return) (/= return 0)) + (save-excursion + (let ((file (nth (- (length files) (length (member ufile ufiles))) files))) + (if (and dired-shell-failure-marker + (dired-goto-file file)) + (let ((dired-marker-char dired-shell-failure-marker)) + (dired-mark 1))) + (setq failures (cons file failures))))) + (setq ufiles (cdr ufiles))) + (if failures + (let ((num (length failures))) + (setq message + (if dired-shell-failure-marker + (format + "Marked %d failure%s with %c." + num (dired-plural-s num) + dired-shell-failure-marker) + "Failed on %d file%s." num + (dired-plural-s num))) + (dired-log + (current-buffer) + "Shell command %s failed (non-zero exit status) for:\n %s" + command failures) + (dired-log (current-buffer) t))) + (dired-run-shell-command-closeout "*Shell Command Output*" message))) + + (t + (dired-bunch-files + (- 10000 (length command)) + (function (lambda (&rest ufiles) + (dired-run-shell-command + (dired-shell-stuff-it command ufiles udir nil) + dir nil) + nil)) ; for the sake of nconc in dired-bunch-files + nil ufiles) + (dired-run-shell-command-closeout "*Shell Command Output*")))) + ;; Update any directories + (or in-background + (let ((dired-no-confirm '(revert-subdirs))) + (dired-verify-modtimes))))) + +(defun dired-do-background-shell-command (command arg files) + "Like \\[dired-do-shell-command], but starts command in background. +Note that you can type input to the command in its buffer. +This requires background.el from the comint package to work." + ;; With the version in emacs-19.el, you can alternatively just + ;; append an `&' to any shell command to make it run in the + ;; background, but you can't type input to it. + (interactive + (let ((on-each (or (equal '(4) current-prefix-arg) + (equal '(16) current-prefix-arg))) + (files (dired-get-marked-files + nil (and (not (consp current-prefix-arg)) + current-prefix-arg))) + (dir (and (not (equal current-prefix-arg '(16))) + (dired-current-directory)))) + (list + (dired-read-shell-command + (concat "& " + (if dir + (format "in %s " (dired-abbreviate-file-name dir)) + "cd ; ") + "on " + (if on-each "each ") + "%s: ") + (and (not on-each) current-prefix-arg) + (if dir + (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files) + files)) + current-prefix-arg files))) + (dired-do-shell-command command arg files t)) + +;;; Printing files + +(defun dired-do-print (&optional arg command files) + "Print the marked (or next ARG) files. +Uses the shell command coming from variable `dired-print-program-alist'." + (interactive + (progn + (if dired-print-history + (setq dired-print-history (dired-uniquefy-list dired-print-history)) + (setq dired-print-history (mapcar 'cdr dired-print-program-alist))) + (let* ((files (dired-get-marked-files nil current-prefix-arg)) + (rel-files (mapcar (function + (lambda (fn) + (dired-make-relative + fn + (dired-current-directory) t))) + files)) + (alist dired-print-program-alist) + (first (car files)) + (dired-print-history (copy-sequence dired-print-history)) + elt initial command) + ;; For gmhist + (put 'dired-print-history 'no-default t) + (if first + (while (and alist (not initial)) + (if (string-match (car (car alist)) first) + (setq initial (cdr (car alist))) + (setq alist (cdr alist))))) + (if (and initial (setq elt (member initial dired-print-history))) + (setq dired-print-history (nconc + (delq (car elt) dired-print-history) + (list initial)))) + (setq command + (dired-mark-read-string + "Print %s with: " + initial 'print current-prefix-arg rel-files + 'dired-print-history)) + (list current-prefix-arg command files)))) + (or files + (setq files (dired-get-marked-files nil arg))) + (while files + (dired-print-file command (car files)) + (setq files (cdr files)))) + +(defun dired-print-file (command file) + ;; Using COMMAND, print FILE. + (let ((handler (find-file-name-handler file 'dired-print-file))) + (if handler + (funcall handler 'dired-print-file command file) + (let ((rel-file (dired-make-relative file (dired-current-directory) t))) + (message "Spooling %s..." rel-file) + (shell-command (dired-trans-command command (list file) "")) + (message "Spooling %s...done" rel-file))))) + +;;; end of dired-shell.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-uu.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-uu.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,116 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-uu.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for uuencoding/uudecoding marked files. +;; Author: Sandy Rutherford +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-uu) +(require 'dired) + +(defvar dired-uu-files-to-decode nil) +;; Fluid var to pass data inside dired-create-files. + +(defun dired-uucode-file (file ok-flag) + ;; uuencode or uudecode FILE. + ;; Don't really support the ok-flag, but needed for compatibility + (let ((handler (find-file-name-handler file 'dired-uucode-file))) + (cond (handler + (funcall handler 'dired-uucode-file file ok-flag)) + ((or (file-symlink-p file) (file-directory-p file)) + nil) + (t + (if (assoc file dired-uu-files-to-decode) + (let ((default-directory (file-name-directory file))) + (if (dired-check-process + (concat "Uudecoding " file) shell-file-name "-c" + (format "uudecode %s" file)) + (signal 'file-error (list "Error uudecoding" file)))) + (let ((nfile (concat file ".uu"))) + (if (dired-check-process + (concat "Uuencoding " file) shell-file-name "-c" + (format "uuencode %s %s > %s" + file (file-name-nondirectory file) nfile)) + (signal 'file-error (list "Error uuencoding" file))))))))) + +(defun dired-uucode-out-file (file) + ;; Returns the name of the output file for the uuencoded FILE. + (let ((buff (get-buffer-create " *dired-check-process output*")) + (case-fold-search t)) + (save-excursion + (set-buffer buff) + (erase-buffer) + (if (string-equal "18." (substring emacs-version 0 3)) + (call-process "head" file buff nil "-n" "1") + (insert-file-contents file nil 0 80)) + (goto-char (point-min)) + (if (looking-at "begin [0-9]+ \\([^\n]*\\)\n") + (expand-file-name + (buffer-substring (match-beginning 1) (match-end 1)) + (file-name-directory file)) + nil)))) + +(defun dired-do-uucode (&optional arg files to-decode) + "Uuencode or uudecode marked (or next ARG) files." + (interactive + (let* ((dir (dired-current-directory)) + (files (dired-get-marked-files nil current-prefix-arg)) + (arg (prefix-numeric-value current-prefix-arg)) + (total (length files)) + rfiles decoders ofile decode encode hint-p) + (mapcar + (function + (lambda (fn) + (if (setq ofile (dired-uucode-out-file fn)) + (setq decoders (cons (cons fn ofile) decoders))))) + files) + (setq decode (length decoders) + encode (- total decode) + hint-p (not (or (zerop decode) (zerop encode)))) + (setq rfiles + (mapcar + (function + (lambda (fn) + (if hint-p + (concat + (if (assoc fn decoders) " [de] " " [en] ") + (dired-make-relative fn dir t)) + (dired-make-relative fn dir t)))) + files)) + (or (memq 'uuencode dired-no-confirm) + (dired-mark-pop-up nil 'uuencode rfiles 'y-or-n-p + (cond + ((null decoders) + (if (= encode 1) + (format "Uuencode %s? " (car rfiles)) + (format "Uuencode %d file%s? " + encode (dired-plural-s encode)))) + ((zerop encode) + (if (= decode 1) + (format "Uudecode %s? " (car rfiles)) + (format "Uudecode %d file%s? " + decode (dired-plural-s decode)))) + (t + (format "Uudecode %d and uuencode %d file%s? " + decode encode (dired-plural-s encode))))) + (setq arg 0)) + (list arg files decoders))) + (let ((dired-uu-files-to-decode to-decode) + out-file) + (if (not (zerop arg)) + (dired-create-files + 'dired-uucode-file + "Uuencode or Uudecode" + files + (function + (lambda (fn) + (if (setq out-file (assoc fn dired-uu-files-to-decode)) + (cdr out-file) + (concat fn ".uu")))) + dired-keep-marker-uucode nil t)))) + +;;; end of dired-uu.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-vir.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-vir.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,137 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-vir.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Virtual dired mode for browsing ls -lR listings. +;; Author: Sebastian Kremer +;; Created: 7-Mar-1991 16:00 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-vir) +(require 'dired) + +(defun dired-virtual (dirname &optional switches) + "Put this buffer into Virtual Dired mode. + +In Virtual Dired mode, all commands that do not actually consult the +filesystem will work. + +This is useful if you want to peruse and move around in an ls -lR +output file, for example one you got from an ftp server. With +efs, you can even dired a directory containing an ls-lR file, +visit that file and turn on virtual dired mode. But don't try to save +this file, as dired-virtual indents the listing and thus changes the +buffer. + +If you have save a Dired buffer in a file you can use \\[dired-virtual] to +resume it in a later session. + +Type \\\\[revert-buffer] in the +Virtual Dired buffer and answer `y' to convert the virtual to a real +dired buffer again. You don't have to do this, though: you can relist +single subdirs using \\[dired-do-redisplay]. +" + + ;; DIRNAME is the top level directory of the buffer. It will become + ;; its `default-directory'. If nil, the old value of + ;; default-directory is used. + + ;; Optional SWITCHES are the ls switches to use. + + ;; Shell wildcards will be used if there already is a `wildcard' + ;; line in the buffer (thus it is a saved Dired buffer), but there + ;; is no other way to get wildcards. Insert a `wildcard' line by + ;; hand if you want them. + + (interactive + (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) + (goto-char (point-min)) + (or (looking-at " ") + ;; if not already indented, do it now: + (indent-region (point-min) (point-max) 2)) + (or dirname (setq dirname default-directory)) + (setq dirname (expand-file-name (file-name-as-directory dirname))) + (setq default-directory dirname) ; contains no wildcards + (let ((wildcard (save-excursion + (goto-char (point-min)) + (forward-line 1) + (and (looking-at "^ wildcard ") + (buffer-substring (match-end 0) + (progn (end-of-line) (point))))))) + (if wildcard + (setq dirname (expand-file-name wildcard default-directory)))) + ;; If raw ls listing (not a saved old dired buffer), give it a + ;; decent subdir headerline: + (goto-char (point-min)) + (or (looking-at dired-subdir-regexp) + (dired-insert-headerline default-directory)) + (dired-mode dirname (or switches dired-listing-switches)) + (setq mode-name "Virtual Dired" + revert-buffer-function 'dired-virtual-revert) + (set (make-local-variable 'dired-subdir-alist) nil) + (dired-build-subdir-alist) + (goto-char (point-min)) + (dired-initial-position dirname)) + +(defun dired-virtual-guess-dir () + + ;; Guess and return appropriate working directory of this buffer, + ;; assumed to be in Dired or ls -lR format. + ;; The guess is based upon buffer contents. + ;; If nothing could be guessed, returns nil. + + (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") + (subexpr 2)) + (goto-char (point-min)) + (cond ((looking-at regexp) + ;; If a saved dired buffer, look to which dir and + ;; perhaps wildcard it belongs: + (let ((dir (buffer-substring (match-beginning subexpr) + (match-end subexpr)))) + (file-name-as-directory dir))) + ;; Else no match for headerline found. It's a raw ls listing. + ;; In raw ls listings the directory does not have a headerline + ;; try parent of first subdir, if any + ((re-search-forward regexp nil t) + (file-name-directory + (directory-file-name + (file-name-as-directory + (buffer-substring (match-beginning subexpr) + (match-end subexpr)))))) + (t ; if all else fails + nil)))) + + +(defun dired-virtual-revert (&optional arg noconfirm) + (if (not + (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) + (error "Cannot revert a Virtual Dired buffer.") + (setq mode-name "Dired" + revert-buffer-function 'dired-revert) + (revert-buffer))) + +;; A zero-arg version of dired-virtual. +;; You need my modified version of set-auto-mode for the +;; `buffer-contents-mode-alist'. +;; Or you use infer-mode.el and infer-mode-alist, same syntax. +(defun dired-virtual-mode () + "Put current buffer into virtual dired mode (see `dired-virtual'). +Useful on `buffer-contents-mode-alist' (which see) with the regexp + + \"^ \\(/[^ /]+\\)/?+:$\" + +to put saved dired buffers automatically into virtual dired mode. + +Also useful for `auto-mode-alist' (which see) like this: + + \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) + auto-mode-alist)\) +" + (interactive) + (dired-virtual (dired-virtual-guess-dir))) + +;;; end of dired-vir.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-xemacs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-xemacs.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,802 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-xemacs.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired functions for XEmacs +;; Author: Mike Sperber +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'dired-xemacs) +(require 'dired) + +(require 'backquote) + +;;; Variables + +;; kludge +(defun dired-demarkify-regexp (re) + (if (string-equal (substring re 0 (length dired-re-maybe-mark)) + dired-re-maybe-mark) + (concat "^" (substring re + (length dired-re-maybe-mark) + (length re))) + re)) + +(defvar dired-do-highlighting t + "Set if we should use highlighting according to filetype.") + +(defvar dired-do-interactive-permissions t + "Set if we should allow interactive chmod.") + +(defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir)) +(defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym)) +(defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe)) + +(defvar dired-re-raw-boring (dired-omit-regexp) + "Regexp to match backup, autosave and otherwise boring files.") + +(defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s")) + +(defvar dired-re-raw-setuid + (concat "^" dired-re-inode-size + "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") + "setuid plain file (even if not executable)") + +(defvar dired-re-raw-setgid + (concat "^" dired-re-inode-size + "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]") + "setgid plain file (even if not executable)") + +(defvar dired-re-pre-permissions "^.? ?[0-9 ]*[-d]" + "Regexp matching the preamble to file permissions part of a dired line. +This shouldn't match socket or symbolic link lines (which aren't editable).") + +(defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]" + "Regexp matching the file permissions part of a dired line.") + +;;; Setup + +(setq dired-modeline-tracking-cmds '(mouse-track)) + +;;; Make needed faces if the user hasn't already done so. +;;; Respect X resources (`make-face' uses them when they exist). + +(let ((change-it + (function (lambda (face) + (or (if (fboundp 'facep) + (facep face) + (memq face (face-list))) + (make-face face)) + (not (face-differs-from-default-p face)))))) + + (if (funcall change-it 'dired-face-marked) + (progn + (set-face-background 'dired-face-marked "PaleVioletRed" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-marked t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-marked t + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-deleted) + (progn + (set-face-background 'dired-face-deleted "LightSlateGray" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-directory) + (make-face-bold 'dired-face-directory)) + (if (funcall change-it 'dired-face-executable) + (progn + (set-face-foreground 'dired-face-executable "SeaGreen" + 'global '(color) 'append) + (make-face-bold 'dired-face-executable))) + (if (funcall change-it 'dired-face-setuid) + (progn + (set-face-foreground 'dired-face-setuid "Red" + 'global '(color) 'append) + (make-face-bold 'dired-face-setuid))) + (if (funcall change-it 'dired-face-socket) + (progn + (set-face-foreground 'dired-face-socket "Gold" + 'global '(color) 'append) + (make-face-italic 'dired-face-socket))) + (if (funcall change-it 'dired-face-symlink) + (progn + (set-face-foreground 'dired-face-symlink "MediumBlue" + 'global '(color) 'append) + (make-face-bold 'dired-face-symlink))) + + (if (funcall change-it 'dired-face-boring) + (progn + (set-face-foreground 'dired-face-boring "Grey" + 'global '(color) 'append) + (set-face-background-pixmap + 'dired-face-boring + [xbm :data (32 2 "\125\125\125\125\252\252\252\252")] + 'global '(mono) 'append) + (set-face-background-pixmap + 'dired-face-boring + [xbm :data (32 2 "\125\125\125\125\252\252\252\252")] + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-permissions) + (progn + (set-face-foreground 'dired-face-permissions "MediumOrchid" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(grayscale) 'append)))) + +;;; Menus + +(defvar dired-subdir-menu nil "The Subdir menu for dired") +(defvar dired-mark-menu nil "The Mark menu for dired") +(defvar dired-do-menu nil "The Do menu for dired") +(defvar dired-regexp-menu nil "The Regexp menu for dired") +(defvar dired-look-menu nil "The Look menu for dired") +(defvar dired-sort-menu nil "The Sort menu for dired") +(defvar dired-help-menu nil "The Help menu for dired") + +(defvar dired-menubar-menus + '(("Subdir" . dired-subdir-menu) + ("Mark" . dired-mark-menu) + ("Do" . dired-do-menu) + ("Regexp" . dired-regexp-menu) + ("Look" . dired-look-menu) + ("Sort" . dired-sort-menu)) + "All the dired menus.") + +(defvar dired-visit-popup-menu nil "The Visit popup for dired") +(defvar dired-do-popup-menu nil "The Do popup for dired") + +(defun dired-setup-menus () + (setq + dired-visit-popup-menu + '(["Find File" dired-find-file t] + ["Find in Other Window" dired-find-file-other-window t] + ["Find in Other Frame" dired-find-file-other-frame t] + ["View File" dired-view-file t] + ["Display in Other Window" dired-find-file-other-window t])) + + (setq + dired-do-popup-menu + '(["Copy to..." dired-do-copy t] + ["Rename to..." dired-do-rename t] + ["Compress/Uncompress" dired-do-compress t] + ["Uuencode/Uudecode" dired-do-uucode t] + ["Change Mode..." dired-do-chmod t] + ["Change Owner..." dired-do-chown t] + ["Change Group..." dired-do-chgrp t] + ["Load" dired-do-load t] + ["Byte-compile" dired-do-byte-compile t] + ["Hardlink to..." dired-do-hardlink t] + ["Symlink to..." dired-do-symlink t] + ["Shell Command..." dired-do-shell-command t] + ["Background Shell Command..." dired-do-background-shell-command t] + ["Delete" dired-do-delete t])) + + (setq + dired-subdir-menu + (list + ["Next Subdir" dired-next-subdir t] + ["Prev Subdir" dired-prev-subdir t] + ["Next Dirline" dired-next-dirline t] + ["Prev Dirline" dired-prev-dirline t] + ["Up Dir" dired-up-directory t] + ["Down Dir" dired-down-directory t] + ["Insert This Subdir" dired-maybe-insert-subdir t] + ["Create Directory..." dired-create-directory t] + ["Kill This Subdir" dired-kill-subdir t] + "-- Commands on All Files in Subdir --" + ["Redisplay Subdir" dired-redisplay-subdir t] + ["Mark Files" dired-mark-subdir-files t] + ["Flag Files for Deletion" dired-flag-subdir-files t] + ["Compress Uncompressed Files" dired-compress-subdir-files t] + (vector "Uncompress Compressed Files" + '(let ((current-prefix-arg t)) + (dired-compress-subdir-files)) + ':keys (dired-key-description 'dired-compress-subdir-files + 'universal-argument)))) + + (setq + dired-mark-menu + (list + ["Next Marked" dired-next-marked-file t] + ["Previous Marked" dired-prev-marked-file t] + ["Change Marks..." dired-change-marks t] + ["Unmark All" dired-unmark-all-files t] + (vector "Toggle marks..." + '(let ((current-prefix-arg t)) + (call-interactively 'dired-change-marks)) + ':keys (dired-key-description 'dired-change-marks + 'universal-argument)) + ["Mark Symlinks" dired-mark-symlinks t] + ["Mark Directories" dired-mark-directories t] + ["Mark Old Backups" dired-clean-directory t] + ["Mark Executables" dired-mark-executables t] + ["Flag Backup Files" dired-flag-backup-files t] + ["Flag Auto-save Files" dired-flag-auto-save-files t] + ["Set new marker char" dired-set-marker-char t] + ["Restore marker char" dired-restore-marker-char t] + ["Marker stack left" dired-marker-stack-left t] + ["Marker stack right" dired-marker-stack-right t] + "---" + ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t] + ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t])) + + (setq + dired-do-menu + '(["Copy to..." dired-do-copy t] + ["Rename to..." dired-do-rename t] + ["Expunge File Flagged for Deletion" dired-expunge-deletions t] + ["Compress/Uncompress" dired-do-compress t] + ["Uuencode/Uudecode" dired-do-uucode t] + ["Print..." dired-do-print t] + ["Change Mode..." dired-do-interactive-chmod t] + ["Change Owner..." dired-do-chown t] + ["Change Group..." dired-do-chgrp t] + ["Byte-compile" dired-do-byte-compile t] + ["Hardlink to..." dired-do-hardlink t] + ["Symlink to..." dired-do-symlink t] + ["Shell Command..." dired-do-shell-command t] + ["Background Shell Command..." dired-do-background-shell-command t] + ["Delete Marked Files" dired-do-delete t] + ["Visit file menu >" dired-visit-popup-menu-internal t] + ["Operate on file menu >" dired-do-popup-menu-internal t])) + + (setq + dired-regexp-menu + (list + ["Mark..." dired-mark-files-regexp t] + ["Mark Files with Extension..." dired-mark-extension t] + ["Flag..." dired-flag-files-regexp t] + ["Flag Files with Extension..." dired-flag-extension t] + ["Downcase" dired-downcase t] + ["Upcase" dired-upcase t] + ["Copy..." dired-do-copy-regexp t] + ["Rename..." dired-do-rename-regexp t] + ["Hardlink..." dired-do-hardlink-regexp t] + ["Symlink..." dired-do-symlink-regexp t] + ["Relative Symlink..." dired-do-relsymlink-regexp t] + "---" + ["Add Omit Regex..." dired-add-omit-regexp t] + (vector "Remove Omit Regex..." + '(let ((current-prefix-arg 1)) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 1)) + (vector "Add Omit Extension..." + '(let ((current-prefix-arg '(4))) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument)) + (vector "Remove Omit Extension..." + '(let ((current-prefix-arg '(16))) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp + 'universal-argument 'universal-argument)) + (vector "Show Omit Regex" + '(let ((current-prefix-arg 0)) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 0)))) + + (setq + dired-look-menu + '(["Grep for..." dired-do-grep t] + ["Tags Search for..." dired-do-tags-search t] + ["Tags Query Replace..." dired-do-tags-query-replace t] + "---" + ["Diff File..." dired-diff t] + ["Diff with Backup" dired-backup-diff t] + ["Merge Files..." dired-emerge t] + ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t] + ["Ediff Files..." dired-ediff t] + ["Patch File" dired-epatch t])) + + (setq + dired-sort-menu + (list + ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t] + (vector "Show Current Switches" + '(dired-sort-toggle-or-edit 0) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 0)) + (vector "Edit Switches for Current Subdir..." + '(dired-sort-toggle-or-edit 1) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 1)) + (vector "Edit Default Switches for Inserted Subdirs..." + '(dired-sort-toggle-or-edit 2) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 2)) + (vector "Sort Entire Buffer by Date" + '(dired-sort-toggle-or-edit 'date) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + (vector "Sort Entire Buffer by Name" + '(dired-sort-toggle-or-edit 'name) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + (vector "Edit Switches for Entire Buffer..." + '(dired-sort-toggle-or-edit '(16)) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + "---" + ["Hide All Subdirs" dired-hide-all t] + ["Hide Subdir" dired-hide-subdir t] + ["Toggle Omit" dired-omit-toggle t] + ["Kill Marked Lines" dired-do-kill-file-lines t] + (vector "Redisplay Killed Lines" + '(dired-do-kill-file-lines 0) + ':keys (dired-key-description 'dired-do-kill-file-lines "0")))) + (setq + dired-help-menu + (list + ["Dired Summary Help" dired-summary t] + ["Describe Dired" dired-describe-mode t] + (vector "Dired Info Manual" + '(dired-describe-mode t) + ':keys (dired-key-description 'dired-describe-mode + 'universal-argument)) + ["Dired Command Apropos" dired-apropos t] + (vector "Dired Variable Apropos" + '(let ((current-prefix-arg t)) + (call-interactively 'dired-apropos)) + ':keys (dired-key-description 'dired-apropos 'universal-argument)) + ["Report Dired Bug" dired-report-bug t]))) + +(defun dired-install-menubar () + "Installs the Dired menu at the menubar." + (if (null dired-help-menu) + (dired-setup-menus)) + (if current-menubar + (progn + (let ((buffer-menubar (copy-sequence current-menubar))) + (delete (assoc "Edit" buffer-menubar) buffer-menubar) + (set-buffer-menubar buffer-menubar) + (mapcar + (function + (lambda (pair) + (let ((name (car pair)) + (menu (symbol-value (cdr pair)))) + (add-submenu nil (cons name menu))))) + dired-menubar-menus)) + (add-menu-button '("Help") (list "---")) + (add-submenu '("Help") (cons "Dired" dired-help-menu))))) + +(add-hook 'dired-mode-hook 'dired-install-menubar) + +;;; Mouse functions + +(defun dired-mouse-find-file (event) + "In dired, visit the file or directory name you click on." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (dired-find-file)) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-mark (event) + "In dired, mark the file name that you click on. +If the file name is already marked, this unmarks it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (beginning-of-line) + (if (looking-at dired-re-mark) + (dired-unmark 1) + (dired-mark 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-flag (event) + "In dired, flag for deletion the file name that you click on. +If the file name is already flag, this unflags it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (beginning-of-line) + (if (char-equal (following-char) dired-del-marker) + (dired-unflag 1) + (dired-flag-file-deletion 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-get-target (event) + "In dired, put a copy of the selected directory in the active minibuffer." + (interactive "e") + (let ((obuff (current-buffer)) + mb) + (set-buffer (window-buffer (event-window event))) + (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) + (let (dir) + (goto-char (event-point event)) + (setq dir (dired-current-directory)) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (set-buffer obuff) + (if mb + (error "No directory specified") + (error "No active minibuffer"))))) + +(defun dired-visit-popup-menu (event) + "Popup a menu to visit the moused file." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (dired-visit-popup-menu-internal event)))) + +(defun dired-visit-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir))) + (popup-menu + (cons (concat "Visit " fn " with") dired-visit-popup-menu)) + ;; this looks like a kludge to me ... + (while (popup-up-p) + (dispatch-event (next-event))))) + +(defun dired-do-popup-menu (event) + "Pop up a menu to do an operation on the moused file." + (interactive "e") + (let ((obuff (current-buffer))) + (unwind-protect + (progn + (set-buffer (window-buffer (event-window event))) + (dired-save-excursion + (goto-char (event-point event)) + (dired-do-popup-menu-internal event))) + (set-buffer obuff)))) + +(defun dired-do-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + (current-prefix-arg 1)) + (popup-menu + (cons (concat "Do operation on " fn) dired-do-popup-menu)) + (while (popup-up-p) + (dispatch-event (next-event))))) + +(defvar dired-filename-local-map + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'dired-filename-local-map) + (define-key map 'button2 'dired-mouse-find-file) + (define-key map 'button3 'dired-visit-popup-menu) + (define-key map '(control button2) 'dired-do-popup-menu) + (define-key map '(shift button1) 'dired-mouse-mark) + (define-key map '(control shift button1) 'dired-mouse-flag) + map) + "Keymap used to activate actions on files in dired.") + +;; Make this defined everywhere in the dired buffer. +(define-key dired-mode-map '(meta button3) 'dired-mouse-get-target) + +;;; Extent managment + +(defun dired-set-text-properties (start end &optional face) + (let ((filename-extent (make-extent start end))) + (set-extent-face filename-extent (or face 'default)) + (set-extent-property filename-extent 'dired-file-name t) + (set-extent-property filename-extent 'start-open t) + (set-extent-property filename-extent 'end-open t) + (set-extent-property filename-extent 'keymap dired-filename-local-map) + (set-extent-property filename-extent 'highlight t) + (set-extent-property + filename-extent 'help-echo + (concat + "button2 finds, button3 visits, " + "C-button2 file ops, [C-]shift-button1 marks/flags.")) + filename-extent)) + +(defun dired-insert-set-properties (beg end) + ;; Sets the extents for the file names and their properties + (save-excursion + (goto-char beg) + (beginning-of-line) + (let ((eol (save-excursion (end-of-line) (point))) + (bol (point)) + start) + (while (< (point) end) + (setq eol (save-excursion (end-of-line) (point))) + + (if dired-do-interactive-permissions + (dired-make-permissions-interactive (point))) + + (if (dired-manual-move-to-filename nil bol eol) + (progn + (setq start (point)) + (dired-manual-move-to-end-of-filename nil bol eol) + (dired-set-text-properties + start + (point) + (save-excursion + (beginning-of-line) + (cond + ((null dired-do-highlighting) nil) + ((looking-at dired-re-raw-dir) 'dired-face-directory) + ((looking-at dired-re-raw-sym) 'dired-face-symlink) + ((or (looking-at dired-re-raw-setuid) + (looking-at dired-re-raw-setgid)) 'dired-face-setuid) + ((looking-at dired-re-raw-exe) 'dired-face-executable) + ((looking-at dired-re-raw-socket) 'dired-face-socket) + ((save-excursion + (goto-char start) + (re-search-forward dired-re-raw-boring eol t)) + 'dired-face-boring)))))) + + (setq bol (1+ eol)) + (goto-char bol))))) + +(defun dired-remove-text-properties (start end) + ;; Removes text properties. Called in popup buffers. + (map-extents + (function + (lambda (extent maparg) + (if (extent-property extent 'dired-file-name) + (delete-extent extent)) + nil)) + nil start end)) + +(defun dired-highlight-filename-mark (extent) + (let ((mark + (save-excursion + (skip-chars-backward "^\n\r") + (following-char))) + (face (extent-face extent))) + (if (char-equal mark ?\ ) + (if (consp face) + (set-extent-face extent (cadr face))) + (let ((new-face + (cond + ((char-equal dired-default-marker mark) + 'dired-face-marked) + ((char-equal dired-del-marker mark) + 'dired-face-deleted) + (t 'default)))) + (set-extent-face + extent + (if (consp face) + (list new-face (cadr face)) + (list new-face face))))))) + +(defun dired-move-to-filename (&optional raise-error bol eol) + (or bol (setq bol (save-excursion + (skip-chars-backward "^\n\r") + (point)))) + (or eol (setq eol (save-excursion + (skip-chars-forward "^\n\r") + (point)))) + (goto-char bol) + (let ((extent + (map-extents + (function + (lambda (extent maparg) + (if (extent-property extent 'dired-file-name) + extent + nil))) + nil bol eol))) + (if extent + (progn + (if dired-do-highlighting + (dired-highlight-filename-mark extent)) + (goto-char (extent-start-position extent))) + (if raise-error + (error "No file on this line") + nil)))) + + +(defun dired-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (let ((filename-extent (map-extents + (function + (lambda (e p) (and (extent-property e p) e))) + (current-buffer) bol eol 'dired-file-name))) + (if filename-extent + (goto-char (extent-end-position filename-extent)) + (and (null no-error) (error "No file on this line"))))) + +;;; Interactive chmod +;;; (based on ideas from Russell Ritchie's dired-chmod.el) + +(defun dired-do-interactive-chmod (new-attribute) + (let* ((file (dired-get-filename)) + (operation (concat "chmod " new-attribute " " file)) + (failure (apply (function dired-check-process) + operation + "chmod" new-attribute (list file)))) + (dired-do-redisplay) + (if failure + (dired-log-summary (buffer-name (current-buffer)) + (format "%s: error" operation) nil)))) + +(defun dired-chmod-popup-menu (event menu) + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (popup-menu menu) + ;; this looks like a kludge to me ... + (while (popup-up-p) + (dispatch-event (next-event)))))) + +;; This is probably overdoing it. +;; Someone give me lexical scoping here ... + +(defun dired-setup-chmod-keymap (domain id keys) + (let* ((names + (mapcar + (function + (lambda (key) + (let ((name (intern (concat "dired-" + (list domain ?- key))))) + (eval + `(defun ,name () + (interactive) + (dired-do-interactive-chmod ,(concat (list domain ?+ key))))) + name))) + keys)) + (prefix (concat "dired-" (list domain) "-" (list id))) + (remove-name (intern (concat prefix "-remove"))) + (toggle-name (intern (concat prefix "-toggle"))) + (mouse-toggle-name (intern (concat prefix "-mouse-toggle"))) + (mouse-menu-name (intern (concat prefix "-menu")))) + + (eval + `(defun ,remove-name () + (interactive) + (cond ,@(mapcar (function + (lambda (key) + `((looking-at ,(regexp-quote (char-to-string key))) + (dired-do-interactive-chmod + ,(concat (list domain ?- key)))))) + keys)))) + + (eval + `(defun ,toggle-name () + (interactive) + (cond ((looking-at "-") (dired-do-interactive-chmod + ,(concat (list domain ?+ (car keys))))) + ,@(let ((l keys) + (c '())) + (while l + (setq c + (cons + `((looking-at (regexp-quote (char-to-string ,(car l)))) + (dired-do-interactive-chmod + ,(if (null (cdr l)) + (concat (list domain ?- (car l))) + (concat (list domain ?+ (cadr l)))))) + c)) + (setq l (cdr l))) + (reverse c))))) + + (eval + `(defun ,mouse-toggle-name (event) + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (,toggle-name))))) + + (let ((menu '()) + (loop-keys keys) + (loop-names names)) + (while loop-keys + (setq menu + (cons (vector (concat (list ?+ (car loop-keys))) + (car loop-names) + t) + menu)) + (setq loop-keys (cdr loop-keys) + loop-names (cdr loop-names))) + (setq menu (append menu (list (vector "Toggle" toggle-name t) + (vector "Clear" remove-name t)))) + (setq menu (cons (char-to-string domain) menu)) + + (eval + `(defun ,mouse-menu-name (event) + (interactive "e") + (dired-chmod-popup-menu event ',menu)))) + + (let ((keymap (make-sparse-keymap))) + (let ((loop-keys (cons ?. (cons ?- keys))) + (loop-names (cons toggle-name (cons remove-name names)))) + (while loop-keys + (define-key keymap (car loop-keys) (car loop-names)) + (setq loop-keys (cdr loop-keys) + loop-names (cdr loop-names)))) + + (define-key keymap 'button2 mouse-toggle-name) + (define-key keymap 'button3 mouse-menu-name) + keymap))) + +(defvar dired-u-r-keymap nil "internal keymap for dired") +(defvar dired-u-w-keymap nil "internal keymap for dired") +(defvar dired-u-x-keymap nil "internal keymap for dired") +(defvar dired-g-r-keymap nil "internal keymap for dired") +(defvar dired-g-w-keymap nil "internal keymap for dired") +(defvar dired-g-x-keymap nil "internal keymap for dired") +(defvar dired-o-r-keymap nil "internal keymap for dired") +(defvar dired-o-w-keymap nil "internal keymap for dired") +(defvar dired-o-x-keymap nil "internal keymap for dired") + + +(defun dired-setup-chmod-keymaps () + (setq + dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r)) + dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w)) + dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?s ?S ?x)) + dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r)) + dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w)) + dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?s ?x)) + dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r)) + dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w)) + dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?s ?t ?x)))) + +(defun dired-make-permissions-interactive (beg) + (save-excursion + (goto-char beg) + (buffer-substring (point) (save-excursion (end-of-line) (point))) + (if (and (re-search-forward dired-re-pre-permissions + (save-excursion (end-of-line) (point)) + t) + (looking-at dired-re-permissions)) + (let ((p (point))) + (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap) + (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap) + (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap) + (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap) + (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap) + (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap) + (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap) + (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap) + (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap))))) + +(defun dired-activate-permissions (extent keymap) + (set-extent-face extent 'dired-face-permissions) + (set-extent-property extent 'keymap keymap) + (set-extent-property extent 'highlight t) + (set-extent-property + extent 'help-echo + "button2 toggles, button3 changes otherwise.")) + +(dired-setup-chmod-keymaps) + +;;; end of dired-xemacs.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired-xy.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-xy.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,52 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-xy.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for reading mail from dired. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-xy) +(require 'dired) + +;;; Special request: Will an mh-e user please write some mh support in here? + +(defun dired-read-mail (&optional arg) + "Reads the current file as a mail folder. +Uses the setting of `dired-mail-reader' to determine which reader to use. +Possibilities are VM or RMAIL. With a prefix arg, visits the folder read-only\; +this only works with VM." + (interactive "P") + (cond + ((eq dired-mail-reader 'vm) + (dired-vm arg)) + ((eq dired-mail-reader 'rmail) + (dired-rmail)) ; doesn't take read-only arg. + (t (error "Never heard of the mail reader %s" dired-mail-reader)))) + +;; Read-only folders only work in VM 5, not in VM 4. +(defun dired-vm (&optional read-only) + "Run VM on this file. +With prefix arg, visit folder read-only (this requires at least VM 5). +See also variable `dired-vm-read-only-folders'." + (interactive "P") + (let ((dir (dired-current-directory)) + (fil (dired-get-filename))) + ;; take care to supply 2nd arg only if requested - may still run VM 4! + (require 'vm) ; vm-visit-folder may not be an autoload + (setq this-command 'vm-visit-folder) ; for vm window config + (if read-only + (vm-visit-folder fil t) + (vm-visit-folder fil)) + ;; so that pressing `v' inside VM does prompt within current directory: + (set (make-local-variable 'vm-folder-directory) dir))) + +(defun dired-rmail () + "Run RMAIL on this file." + (interactive) + (rmail (dired-get-filename))) + +;; end of dired-xy.el + diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,6439 @@ + ; -*- Emacs-Lisp -*- +;; DIRED commands for Emacs. +;; Copyright (C) 1985, 1986, 1991 Free Software Foundation, Inc. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired.el +;; RCS: +;; Dired Version: $Revision: 1.2 $ +;; Description: The DIRectory EDitor is for manipulating, and running +;; commands on files in a directory. +;; Authors: FSF, +;; Sebastian Kremer , +;; Sandy Rutherford +;; Cast of thousands... +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; Rewritten in 1990/1991 to add tree features, file marking and +;; sorting by Sebastian Kremer . +;; 7-1993: Added special features for efs interaction and upgraded to Emacs 19. +;; Sandy Rutherford + +;;; Dired Version + +(defconst dired-version (substring "$Revision: 1.2 $" 11 -2) + "The revision number of Tree Dired (as a string). + +Don't forget to mention this when reporting bugs to: + + efs-bugs@cuckoo.hpl.hp.com") + +;; Global key bindings: +;; -------------------- +;; +;; By convention, dired uses the following global key-bindings. +;; These may or may not already be set up in your local emacs. If not +;; then you will need to add them to your .emacs file, or the system +;; default.el file. We don't set them automatically here, as users may +;; have individual preferences. +;; +;; (define-key ctl-x-map "d" 'dired) +;; (define-key ctl-x-4-map "d" 'dired-other-window) +;; (define-key ctl-x-map "\C-j" 'dired-jump-back) +;; (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) +;; +;; For V19 emacs only. (Make sure that the ctl-x-5-map exists.) +;; (define-key ctl-x-5-map "d" 'dired-other-frame) +;; (define-key Ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) + + +;;; Grok the current emacs version +;; +;; Hopefully these two variables provide us with enough version sensitivity. + +;; Make sure that we have a frame-width function +(or (fboundp 'frame-width) (fset 'frame-width 'screen-width)) + +;;; Requirements and provisions + +(provide 'dired) +(require 'backquote) ; For macros. + +;; Compatibility requirements for the file-name-handler-alist. +(let ((lucid-p (string-match "Lucid" emacs-version)) + ver subver) + (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) + (error "dired does not work with emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version (match-beginning 1) + (match-end 1))) + subver (string-to-int (substring emacs-version (match-beginning 2) + (match-end 2)))) + (cond + ((= ver 18) + (require 'emacs-19) + (require 'fn-handler)) + ((and (= ver 19) (if lucid-p (< subver 10) (< subver 23))) + (require 'fn-handler)) + ((< ver 18) + (error "dired does not work with emacs version %s" emacs-version)))) + +;; Load default-dir last, because we want its interactive specs. +(require 'default-dir) + + +;;;;---------------------------------------------------------------- +;;;; Customizable variables +;;;;---------------------------------------------------------------- +;; +;; The funny comments are for autoload.el, to automagically update +;; loaddefs. + +;;; Variables for compressing files. + +;;;###autoload +(defvar dired-compression-method 'compress + "*Type of compression program to use. +Give as a symbol. +Currently-recognized methods are: gzip pack compact compress. +To change this variable use \\[dired-do-compress] with a zero prefix.") + +;;;###autoload +(defvar dired-compression-method-alist + '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") + ;; Put compress before pack, so that it wins out if we are using + ;; efs to work on a case insensitive OS. The -f flag does + ;; two things in compress. No harm in giving it twice. + (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") + ;; pack support may not work well. pack is too chatty and there is no way + ;; to force overwrites. + (pack ".z" ("pack" "-f") ("unpack")) + (compact ".C" ("compact") ("uncompact"))) + + "*Association list of compression method descriptions. + Each element of the table should be a list of the form + + \(compress-type extension (compress-args) (decompress-args) force-flag\) + + where + `compress-type' is a unique symbol in the alist to which + `dired-compression-method' can be set; + `extension' is the file extension (as a string) used by files compressed + by this method; + `compress-args' is a list of the path of the compression program and + flags to pass as separate arguments; + `decompress-args' is a list of the path of the decompression + program and flags to pass as separate arguments. + `force-flag' is the switch to pass to the command to force overwriting + of existing files. + + For example: + + \(setq dired-compresssion-method-alist + \(cons '\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\) \"-f\"\) + dired-compression-method-alist\)\) + => \(\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\)\) + \(gzip \".gz\" \(\"gzip\"\) \(\"gunzip\"\)\) + ...\) + + See also: dired-compression-method ") + +;;; Variables for the ls program. + +;;;###autoload +(defvar dired-ls-program "ls" + "*Absolute or relative name of the ls program used by dired.") + +;;;###autoload +(defvar dired-listing-switches "-al" + "*Switches passed to ls for dired. MUST contain the `l' option. +Can contain even `F', `b', `i' and `s'.") + +(defvar dired-ls-F-marks-symlinks + (memq system-type '(aix-v3 hpux silicon-graphics-unix)) + ;; Both SunOS and Ultrix have system-type berkeley-unix. But + ;; SunOS doesn't mark symlinks, but Ultrix does. Therefore, + ;; can't grok this case. + "*Informs dired about how ls -lF marks symbolic links. +Set this to t if `dired-ls-program' with -lF marks the name of the symbolic +link itself with a trailing @. + +For example: If foo is a link pointing to bar, and \"ls -F bar\" gives + + ... bar -> foo + +set this variable to nil. If it gives + + ... bar@ -> foo + +set this variable to t. + +Dired checks if there is really a @ appended. Thus, if you have a +marking ls program on one host and a non-marking on another host, and +don't care about symbolic links which really end in a @, you can +always set this variable to t. + +If you use efs, it will make this variable buffer-local, and control +it according to its assessment of how the remote host marks symbolic +links.") + +(defvar dired-show-ls-switches nil + "*If non-nil dired will show the dired ls switches on the modeline. +If nil, it will indicate how the files are sorted by either \"by name\" or +\"by date\". If it is unable to recognize the sorting defined by the switches, +then the switches will be shown explicitly on the modeline, regardless of the +setting of this variable.") + +;;; Variables for other unix utility programs. + +;; For most program names, don't use absolute paths so that dired +;; uses the user's value of the environment variable PATH. chown is +;; an exception as it is not always in the PATH. + +;;;###autoload +(defvar dired-chown-program + (if (memq system-type '(hpux dgux usg-unix-v)) "chown" "/etc/chown") + "*Name of chown command (usully `chown' or `/etc/chown').") + +;;;###autoload +(defvar dired-gnutar-program nil + "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). +GNU tar's `z' switch is used for compressed tar files. +If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") + +;;;###autoload +(defvar dired-unshar-program nil + "*Set to the name of the unshar program, if you have it.") + +;;; Markers + +(defvar dired-keep-marker-rename t + ;; Use t as default so that moved files `take their markers with them' + "*Controls marking of renamed files. +If t, files keep their previous marks when they are renamed. +If a character, renamed files (whether previously marked or not) +are afterward marked with that character.") + +(defvar dired-keep-marker-compress t + "*Controls marking of compressed or uncompressed files. +If t, files keep their previous marks when they are compressed. +If a character, compressed or uncompressed files (whether previously +marked or not) are afterward marked with that character.") + +(defvar dired-keep-marker-uucode ?U + "*Controls marking of uuencoded or uudecoded files. +If t, files keep their previous marks when they are uuencoded. +If a character, uuencoded or uudecoded files (whether previously +marked or not) are afterward marked with that character.") + +(defvar dired-keep-marker-copy ?C + "*Controls marking of copied files. +If t, copied files are marked if and as the corresponding original files were. +If a character, copied files are unconditionally marked with that character.") + +(defvar dired-keep-marker-hardlink ?H + "*Controls marking of newly made hard links. +If t, they are marked if and as the files linked to were marked. +If a character, new links are unconditionally marked with that character.") + +(defvar dired-keep-marker-symlink ?S + "*Controls marking of newly made symbolic links. +If t, they are marked if and as the files linked to were marked. +If a character, new links are unconditionally marked with that character.") + +(defvar dired-keep-marker-kill ?K + "*When killed file lines are redisplayed, they will have this marker. +Setting this to nil means that they will not have any marker.") + +(defvar dired-failed-marker-shell ?! + "*If non-nil, a character with which to mark files of failed shell commands. +Applies to the command `dired-do-shell-command'. Files for which the shell +command has a nonzero exit status will be marked with this character") + +;;; Behavioral Variables + +;;;###autoload +(defvar dired-local-variables-file ".dired" + "*If non-nil, filename for local variables for Dired. +If Dired finds a file with that name in the current directory, it will +temporarily insert it into the dired buffer and run `hack-local-variables'. + +Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on +local variables.") + +;; Usually defined in files.el. Define here anyway, to be safe. +;;;###autoload +(defvar dired-kept-versions 2 + "*When cleaning directory, number of versions to keep.") + +;;;###autoload +(defvar dired-find-subdir nil + "*Determines whether dired tries to lookup a subdir in existing buffers. +If non-nil, dired does not make a new buffer for a directory if it can be +found (perhaps as subdir) in some existing dired buffer. If there are several +dired buffers for a directory, then the most recently used one is chosen. + +Dired avoids switching to the current buffer, so that if you have +a normal and a wildcard buffer for the same directory, C-x d RET will +toggle between those two.") + +;;;###autoload +(defvar dired-use-file-transformers t + "*Determines whether dired uses file transformers. +If non-nil `dired-do-shell-command' will apply file transformers to file names. +See \\[describe-function] for dired-do-shell-command for more information.") + +;;;###autoload +(defvar dired-dwim-target nil + "*If non-nil, dired tries to guess a default target directory. +This means that if there is a dired buffer displayed in the next window, +use its current subdir, instead of the current subdir of this dired buffer. +The target is put in the prompt for file copy, rename, etc.") + +;;;###autoload +(defvar dired-copy-preserve-time nil + "*If non-nil, Dired preserves the last-modified time in a file copy. +\(This works on only some systems.)\\ +Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") + +;;;###autoload +(defvar dired-no-confirm nil + "*If non-nil, a list of symbols for commands dired should not confirm. +It can be a sublist of + + '(byte-compile chgrp chmod chown compress copy delete hardlink load + move print shell symlink uncompress recursive-delete kill-file-buffer + kill-dired-buffer patch create-top-dir revert-subdirs) + +The meanings of most of the symbols are obvious. A few exceptions: + + 'compress applies to compression or decompression by any of the + compression program in `dired-compression-method-alist'. + + 'kill-dired-buffer applies to offering to kill dired buffers for + directories which have been deleted. + + 'kill-file-buffer applies to offering to kill buffers visiting files + which have been deleted. + + 'recursive-delete applies to recursively deleting non-empty + directories, and all of their contents. + + 'create-top-dir applies to `dired-up-directory' creating a new top level + directory for the dired buffer. + + 'revert-subdirs applies to re-reading subdirectories which have + been modified on disk. + +Note that this list also applies to remote files accessed with efs +or ange-ftp.") + +;;;###autoload +(defvar dired-backup-if-overwrite nil + "*Non-nil if Dired should ask about making backups before overwriting files. +Special value 'always suppresses confirmation.") + +;;;###autoload +(defvar dired-omit-files nil + "*If non-nil un-interesting files will be omitted from this dired buffer. +Use \\[dired-omit-toggle] to see these files. (buffer local)") +(make-variable-buffer-local 'dired-omit-files) + +;;;###autoload +(defvar dired-mail-reader 'rmail + "*Mail reader used by dired for dired-read-mail \(\\[dired-read-mail]\). +The symbols 'rmail and 'vm are the only two allowed values.") + +(defvar dired-verify-modtimes t + "*If non-nil dired will revert dired buffers for modified subdirectories. +See also dired-no-confirm .") + +;;; File name regular expressions and extensions. + +(defvar dired-trivial-filenames "^\\.\\.?$\\|^#" + "*Regexp of files to skip when finding first file of a directory listing. +A value of nil means move to the subdir line. +A value of t means move to first file.") + +(defvar dired-cleanup-alist + (list + '("tex" ".toc" ".log" ".aux" ".dvi") + '("latex" ".toc" ".log" ".aux" ".idx" ".lof" ".lot" ".glo" ".dvi") + '("bibtex" ".blg" ".bbl") + '("texinfo" ".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" + ".tp" ".tps" ".vr" ".vrs") + '("patch" ".rej" ".orig") + '("backups" "~") + (cons "completion-ignored-extensions" completion-ignored-extensions)) + "*Alist of extensions for temporary files created by various programs. +Used by `dired-cleanup'.") + +(defvar dired-omit-extensions + (let ((alist dired-cleanup-alist) + x result) + (while alist + (setq x (cdr (car alist)) + alist (cdr alist)) + (while x + (or (member (car x) result) + (setq result (cons (car x) result))) + (setq x (cdr x)))) + result) + "*List of extensions for file names that will be omitted (buffer-local). +This only has effect when the subdirectory is in omission mode. +To make omission mode the default, set `dired-omit-files' to t. +See also `dired-omit-extensions'.") +(make-variable-buffer-local 'dired-omit-extensions) + +(defvar dired-omit-regexps '("^#" "^\\.") + "*File names matching these regexp may be omitted (buffer-local). +This only has effect when the subdirectory is in omission mode. +To make omission mode the default, set `dired-omit-files' to t. +This only has effect when `dired-omit-files-p' is t. +See also `dired-omit-extensions'.") +(make-variable-buffer-local 'dired-omit-files-regexp) + +(defvar dired-filename-re-ext "\\..+$" ; start from the first dot. last dot? + "*Defines what is the extension of a file name. +\(match-beginning 0\) for this regexp in the file name without directory will +be taken to be the start of the extension.") + +;;; Hook variables + +(defvar dired-load-hook nil + "Run after loading dired. +You can customize key bindings or load extensions with this.") + +(defvar dired-grep-load-hook nil + "Run after loading dired-grep.") + +(defvar dired-mode-hook nil + "Run at the very end of dired-mode.") + +(defvar dired-before-readin-hook nil + "Hook run before a dired buffer is newly read in, created,or reverted.") + +(defvar dired-after-readin-hook nil + "Hook run after each listing of a file or directory. +The buffer is narrowed to the new listing.") + +(defvar dired-setup-keys-hook nil + "Hook run when dired sets up its keymap. +This happens the first time that `dired-mode' is called, and runs after +`dired-mode-hook'. This hook can be used to make alterations to the +dired keymap.") + +;;; Internal variables +;; +;; If you set these, know what you are doing. + +;;; Marker chars. + +(defvar dired-marker-char ?* ; the answer is 42 + ; life the universe and everything + ;; so that you can write things like + ;; (let ((dired-marker-char ?X)) + ;; ;; great code using X markers ... + ;; ) + ;; For example, commands operating on two sets of files, A and B. + ;; Or marking files with digits 0-9. This could implicate + ;; concentric sets or an order for the marked files. + ;; The code depends on dynamic scoping on the marker char. + "In dired, character used to mark files for later commands.") +(make-variable-buffer-local 'dired-marker-char) + +(defconst dired-default-marker dired-marker-char) +;; Stores the default value of dired-marker-char when dynamic markers +;; are being used. + +(defvar dired-del-marker ?D + "Character used to flag files for deletion.") + +;; \017=^O for Omit - other packages can chose other control characters. +(defvar dired-omit-marker-char ?\017) +;; Marker used for omitted files. Shouldn't be used by anything else. + +(defvar dired-kill-marker-char ?\C-k) +;; Marker used by dired-do-kill. Shouldn't be used by anything else. + +;;; State variables + +(defvar dired-mode-line-modified "-%s%s%s-" + "*Format string to show the modification status of the buffer.") + +(defvar dired-del-flags-number 0) +(make-variable-buffer-local 'dired-del-flags-number) +(defvar dired-marks-number 0) +(make-variable-buffer-local 'dired-marks-number) +(defvar dired-other-marks-number 0) +(make-variable-buffer-local 'dired-other-marks-number) + +(defvar dired-marked-files nil + "List of filenames from last `dired-copy-filename-as-kill' call.") + +(defvar dired-directory nil + "The directory name or shell wildcard that was used as argument to `ls'. +Local to each dired buffer. May be a list, in which case the car is the +directory name and the cdr is the actual files to list.") +(make-variable-buffer-local 'dired-directory) + +(defvar dired-internal-switches nil + "The actual (buffer-local) value of `dired-listing-switches'. +The switches are represented as a list of characters.") +(make-variable-buffer-local 'dired-internal-switches) + +(defvar dired-subdir-alist nil + "Association list of subdirectories and their buffer positions. +Each subdirectory has an element: (DIRNAME . STARTMARKER). +The order of elements is the reverse of the order in the buffer.") +(make-variable-buffer-local 'dired-subdir-alist) + +(defvar dired-curr-subdir-min 0) +;; Cache for modeline tracking of the cursor +(make-variable-buffer-local 'dired-curr-subdir-min) + +(defvar dired-curr-subdir-max 0) +;; Cache for modeline tracking of the cursor +(make-variable-buffer-local 'dired-curr-subdir-max) + +(defvar dired-subdir-omit nil) +;; Controls whether the modeline shows Omit. +(make-variable-buffer-local 'dired-subdir-omit) + +(defvar dired-in-query nil) +;; let-bound to t when dired is in the process of querying the user. +;; This is to keep asynch messaging from clobbering the query prompt. + +(defvar dired-overwrite-confirmed nil) +;; Fluid variable used to remember if a bunch of overwrites have been +;; confirmed. + +(defvar dired-overwrite-backup-query nil) +;; Fluid var used to remember if backups have been requested for overwrites. + +(defvar dired-file-creator-query nil) +;; Fluid var to remember responses to file-creator queries. + +(defvar dired-omit-silent nil) +;; This is sometimes let-bound to t if messages would be annoying, +;; e.g., in dired-awrh.el. Binding to 0, only suppresses +;; \"(Nothing to omit)\" message. + +(defvar dired-buffers nil + ;; Enlarged by dired-advertise + ;; Queried by function dired-buffers-for-dir. When this detects a + ;; killed buffer, it is removed from this list. + "Alist of directories and their associated dired buffers.") + +(defvar dired-sort-mode nil + "Whether Dired sorts by name, date, etc. +\(buffer-local\)") +;; This is nil outside dired buffers so it can be used in the modeline +(make-variable-buffer-local 'dired-sort-mode) + +(defvar dired-marker-stack nil + "List of previously used dired marker characters.") +(make-variable-buffer-local 'dired-marker-stack) + +(defvar dired-marker-stack-pointer 0) +;; Points to the current marker in the stack +(make-variable-buffer-local 'dired-marker-stack-pointer) + +(defvar dired-marker-stack-cursor ?\ ; space + "Character to use as a cursor in the dired marker stack.") + +(defconst dired-marker-string "" + "String version of `dired-marker-stack'.") +(make-variable-buffer-local 'dired-marker-string) + +(defvar dired-modeline-tracking-cmds nil) +;; List of commands after which the modeline gets updated. + +;;; Config. variables not usually considered fair game for the user. + +(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? + +(defvar dired-log-buffer "*Dired log*") +;; Name of buffer used to log dired messages and errors. + +;;; Assoc. lists + +;; For pop ups and user input for file marking +(defvar dired-query-alist + '((?\y . y) (?\040 . y) ; `y' or SPC means accept once + (?n . n) (?\177 . n) ; `n' or DEL skips once + (?! . yes) ; `!' accepts rest + (?q. no) (?\e . no) ; `q' or ESC skips rest + ;; None of these keys quit - use C-g for that. + )) + +(defvar dired-sort-type-alist + ;; alist of sort flags, and the sort type, as a symbol. + ;; Don't put ?r in here. It's handled separately. + '((?t . date) (?S . size) (?U . unsort) (?X . ext))) + +;;; Internal regexps for examining ls listings. +;; +;; Many of these regexps must be tested at beginning-of-line, but are also +;; used to search for next matches, so neither omitting "^" nor +;; replacing "^" by "\n" (to make it slightly faster) will work. + +(defvar dired-re-inode-size "[ \t0-9]*") +;; Regexp for optional initial inode and file size. +;; Must match output produced by ls' -i and -s flags. + +(defvar dired-re-mark "^[^ \n\r]") +;; Regexp matching a marked line. +;; Important: the match ends just after the marker. + +(defvar dired-re-maybe-mark "^. ") + +(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) +;; Matches directory lines + +(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) +;; Matches symlink lines + +(defvar dired-re-exe;; match ls permission string of an executable file + (mapconcat (function + (lambda (x) + (concat dired-re-maybe-mark dired-re-inode-size x))) + '("-[-r][-w][xs][-r][-w].[-r][-w]." + "-[-r][-w].[-r][-w][xs][-r][-w]." + "-[-r][-w].[-r][-w].[-r][-w][xst]") + "\\|")) + +(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' +;; . and .. files + +(defvar dired-re-month-and-time + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct\\|Nov\\|" + ; June and July are for HP-UX 9.0 + "Dec\\) [ 0-3][0-9]\\(" + " [012][0-9]:[0-6][0-9] \\|" ; time + " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo, + ; HP-UX, A/UX + " [12][90][0-9][0-9] \\)" ; year on AIX + )) +;; This regexp MUST match all the way to first character of the filename. +;; You can loosen it to taste, but then you might bomb on filenames starting +;; with a space. This will have to be modified for non-english month names. + +(defvar dired-subdir-regexp + "\\([\n\r]\n\\|\\`\\). \\([^\n\r]+\\)\\(:\\)\\(\\.\\.\\.\r\\|[\n\r]\\)") + ;; Regexp matching a maybe hidden subdirectory line in ls -lR output. + ;; Subexpression 2 is the subdirectory proper, no trailing colon. + ;; Subexpression 3 must end right before the \n or \r at the end of + ;; the subdir heading. Matches headings after indentation has been done. + +(defvar dired-unhandle-add-files nil) +;; List of files that the dired handler function need not add to dired buffers. +;; This is because they have already been added, most likely in +;; dired-create-files. This is because dired-create-files add files with +;; special markers. + +;;; history variables + +(defvar dired-regexp-history nil + "History list of regular expressions used in Dired commands.") + +(defvar dired-chmod-history nil + "History of arguments to chmod in dired.") + +(defvar dired-chown-history nil + "History of arguments to chown in dired.") + +(defvar dired-chgrp-history nil + "History of arguments to chgrp in dired.") + +(defvar dired-cleanup-history nil + "History of arguments to dired-cleanup.") + +(defvar dired-goto-file-history nil) +;; History for dired-goto-file and dired-goto-subdir +(put 'dired-goto-file-history 'cursor-end t) ; for gmhist + +(defvar dired-history nil) +;; Catch-all history variable for dired file ops without +;; their own history. + +(defvar dired-op-history-alist + ;; alist of dired file operations and history symbols + '((chgrp . dired-chgrp-history) (chown . dired-chown-history) + (chmod . dired-chmod-history) )) + +;;; Tell the byte-compiler that we know what we're doing. +;;; Do we? + +(defvar file-name-handler-alist) +(defvar inhibit-file-name-operation) +(defvar inhibit-file-name-handlers) +(defvar efs-dired-host-type) + + +;;;;------------------------------------------------------------------ +;;;; Utilities +;;;;------------------------------------------------------------------ + +;;; Macros +;; +;; Macros must be defined before they are used - for the byte compiler. + +(defmacro dired-get-subdir-min (elt) + ;; Returns the value of the subdir minumum for subdir with entry ELT in + ;; dired-subdir-alist. + (list 'nth 1 elt)) + +(defmacro dired-save-excursion (&rest body) + ;; Saves excursions of the point (not buffer) in dired buffers. + ;; It tries to be robust against deletion of the region about the point. + ;; Note that this assumes only dired-style deletions. + (let ((temp-bolm (make-symbol "bolm")) + (temp-fnlp (make-symbol "fnlp")) + (temp-offset-bol (make-symbol "offset-bol"))) + (` (let (((, temp-bolm) (make-marker)) + (, temp-fnlp) (, temp-offset-bol)) + (let ((bol (save-excursion (skip-chars-backward "^\n\r") (point)))) + (set-marker (, temp-bolm) bol) + (setq (, temp-offset-bol) (- (point) bol) + (, temp-fnlp) (memq (char-after bol) '(?\n\ ?\r)))) + (unwind-protect + (progn + (,@ body)) + ;; Use the marker to try to find the right line, then move to + ;; the proper column. + (goto-char (, temp-bolm)) + (and (not (, temp-fnlp)) + (not (eq (following-char) 0)) (memq (following-char) '(?\n ?\r)) + ;; The line containing the point got deleted. Note that this + ;; logic only works if we don't delete null lines, but we never + ;; do. + (forward-line 1)) ; don't move into a hidden line. + (skip-chars-forward "^\n\r" (+ (point) (, temp-offset-bol)))))))) + +(put 'dired-save-excursion 'lisp-indent-hook 0) + +(defun dired-substitute-marker (pos old new) + ;; Change marker, re-fontify + (subst-char-in-region pos (1+ pos) old new) + (dired-move-to-filename)) + +(defmacro dired-mark-if (predicate msg) + ;; Mark all files for which CONDITION evals to non-nil. + ;; CONDITION is evaluated on each line, with point at beginning of line. + ;; MSG is a noun phrase for the type of files being marked. + ;; It should end with a noun that can be pluralized by adding `s'. + ;; Return value is the number of files marked, or nil if none were marked. + (let ((temp-pt (make-symbol "pt")) + (temp-count (make-symbol "count")) + (temp-msg (make-symbol "msg"))) + (` (let (((, temp-msg) (, msg)) + ((, temp-count) 0) + (, temp-pt) buffer-read-only) + (save-excursion + (if (, temp-msg) (message "Marking %ss..." (, temp-msg))) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (, predicate) + (not (char-equal (following-char) dired-marker-char))) + (progn + ;; Doing this rather than delete-char, insert + ;; avoids re-computing markers + (setq (, temp-pt) (point)) + (dired-substitute-marker + (, temp-pt) + (following-char) dired-marker-char) + (setq (, temp-count) (1+ (, temp-count))))) + (forward-line 1)) + (if (, temp-msg) + (message "%s %s%s %s%s." + (, temp-count) + (, temp-msg) + (dired-plural-s (, temp-count)) + (if (eq dired-marker-char ?\040) "un" "") + (if (eq dired-marker-char dired-del-marker) + "flagged" "marked")))) + (and (> (, temp-count) 0) (, temp-count)))))) + +(defmacro dired-map-over-marks (body arg &optional show-progress) +;; Perform BODY with point somewhere on each marked line +;; and return a list of BODY's results. +;; If no marked file could be found, execute BODY on the current line. +;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) +;; files instead of the marked files. +;; If ARG is t, only apply to marked files. If there are no marked files, +;; the result is a noop. +;; If ARG is otherwise non-nil, use current file instead. +;; If optional third arg SHOW-PROGRESS evaluates to non-nil, +;; redisplay the dired buffer after each file is processed. +;; No guarantee is made about the position on the marked line. +;; BODY must ensure this itself if it depends on this. +;; Search starts at the beginning of the buffer, thus the car of the list +;; corresponds to the line nearest to the buffer's bottom. This +;; is also true for (positive and negative) integer values of ARG. +;; To avoid code explosion, BODY should not be too long as it is +;; expanded four times. +;; +;; Warning: BODY must not add new lines before point - this may cause an +;; endless loop. +;; This warning should not apply any longer, sk 2-Sep-1991 14:10. + (let ((temp-found (make-symbol "found")) + (temp-results (make-symbol "results")) + (temp-regexp (make-symbol "regexp")) + (temp-curr-pt (make-symbol "curr-pt")) + (temp-next-position (make-symbol "next-position"))) + (` (let (buffer-read-only case-fold-search (, temp-found) (, temp-results)) + (dired-save-excursion + (if (and (, arg) (not (eq (, arg) t))) + (if (integerp (, arg)) + (and (not (zerop (, arg))) + (progn;; no save-excursion, want to move point. + (dired-repeat-over-lines + arg + (function (lambda () + (if (, show-progress) (sit-for 0)) + (setq (, temp-results) + (cons (, body) + (, temp-results)))))) + (if (< (, arg) 0) + (nreverse (, temp-results)) + (, temp-results)))) + ;; non-nil, non-integer ARG means use current file: + (list (, body))) + (let (((, temp-regexp) + (concat "^" (regexp-quote (char-to-string + dired-marker-char)))) + (, temp-curr-pt) (, temp-next-position)) + (save-excursion + (goto-char (point-min)) + ;; remember position of next marked file before BODY + ;; can insert lines before the just found file, + ;; confusing us by finding the same marked file again + ;; and again and... + (setq (, temp-next-position) + (and (re-search-forward (, temp-regexp) nil t) + (point-marker)) + (, temp-found) (not (null (, temp-next-position)))) + (while (, temp-next-position) + (setq (, temp-curr-pt) (goto-char (, temp-next-position)) + ;; need to get next position BEFORE body + (, temp-next-position) + (and (re-search-forward (, temp-regexp) nil t) + (point-marker))) + (goto-char (, temp-curr-pt)) + (if (, show-progress) (sit-for 0)) + (setq (, temp-results) (cons (, body) (, temp-results))))) + (if (, temp-found) + (, temp-results) + ;; Do current file, unless arg is t + (and (not (eq (, arg) t)) + (list (, body))))))))))) + +;;; General utility functions + +(defun dired-buffer-more-recently-used-p (buffer1 buffer2) + "Return t if BUFFER1 is more recently used than BUFFER2." + (if (equal buffer1 buffer2) + nil + (let ((more-recent nil) + (list (buffer-list))) + (while (and list + (not (setq more-recent (equal buffer1 (car list)))) + (not (equal buffer2 (car list)))) + (setq list (cdr list))) + more-recent))) + +(defun dired-file-modtime (file) + ;; Return the modtime of FILE, which is assumed to be already expanded + ;; by expand-file-name. + (let ((handler (find-file-name-handler file 'dired-file-modtime))) + (if handler + (funcall handler 'dired-file-modtime file) + (nth 5 (file-attributes file))))) + +(defun dired-set-file-modtime (file alist) + ;; Set the modtime for FILE in the subdir alist ALIST. + (let ((handler (find-file-name-handler file 'dired-set-file-modtime))) + (if handler + (funcall handler 'dired-set-file-modtime file alist) + (let ((elt (assoc file alist))) + (if elt + (setcar (nthcdr 4 elt) (nth 5 (file-attributes file)))))))) + +(defun dired-map-over-marks-check (fun arg op-symbol operation + &optional show-progress no-confirm) + ;; Map FUN over marked files (with second ARG like in dired-map-over-marks) + ;; and display failures. + + ;; FUN takes zero args. It returns non-nil (the offending object, e.g. + ;; the short form of the filename) for a failure and probably logs a + ;; detailed error explanation using function `dired-log'. + + ;; OP-SYMBOL is s symbol representing the operation. + ;; eg. 'compress + + ;; OPERATION is a string describing the operation performed (e.g. + ;; "Compress"). It is used with `dired-mark-pop-up' to prompt the user + ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. + ;; `Failed to compress 1 of 2 files - type y to see why ("foo")') + + ;; SHOW-PROGRESS if non-nil means redisplay dired after each file. + + (if (or no-confirm (dired-mark-confirm op-symbol operation arg)) + (let* ((total-list;; all of FUN's return values + (dired-map-over-marks (funcall fun) arg show-progress)) + (total (length total-list)) + (failures (delq nil total-list)) + (count (length failures))) + (if (not failures) + (message "%s: %d file%s." operation total (dired-plural-s total)) + (message "Failed to %s %d of %d file%s - type y to see why %s" + operation count total (dired-plural-s total) + ;; this gives a short list of failed files in parens + ;; which may be sufficient for the user even + ;; without typing `W' for the process' diagnostics + failures) + ;; end this bunch of errors: + (dired-log-summary + (buffer-name (current-buffer)) + (format + "Failed to %s %d of %d file%s" + operation count total (dired-plural-s total)) + failures))))) + +(defun dired-make-switches-string (list) +;; Converts a list of cracters to a string suitable for passing to ls. + (concat "-" (mapconcat 'char-to-string list ""))) + +(defun dired-make-switches-list (string) +;; Converts a string of ls switches to a list of characters. + (delq ?- (mapcar 'identity string))) + +;; Cloning replace-match to work on strings instead of in buffer: +;; The FIXEDCASE parameter of replace-match is not implemented. +(defun dired-string-replace-match (regexp string newtext + &optional literal global) + ;; Replace first match of REGEXP in STRING with NEWTEXT. + ;; If it does not match, nil is returned instead of the new string. + ;; Optional arg LITERAL means to take NEWTEXT literally. + ;; Optional arg GLOBAL means to replace all matches. + (if global + (let ((result "") (start 0) mb me) + (while (string-match regexp string start) + (setq mb (match-beginning 0) + me (match-end 0) + result (concat result + (substring string start mb) + (if literal + newtext + (dired-expand-newtext string newtext))) + start me)) + (if mb ; matched at least once + (concat result (substring string start)) + nil)) + ;; not GLOBAL + (if (not (string-match regexp string 0)) + nil + (concat (substring string 0 (match-beginning 0)) + (if literal newtext (dired-expand-newtext string newtext)) + (substring string (match-end 0)))))) + +(defun dired-expand-newtext (string newtext) + ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. + ;; Note that in Emacs 18 match data are clipped to current buffer + ;; size...so the buffer should better not be smaller than STRING. + (let ((pos 0) + (len (length newtext)) + (expanded-newtext "")) + (while (< pos len) + (setq expanded-newtext + (concat expanded-newtext + (let ((c (aref newtext pos))) + (if (= ?\\ c) + (cond ((= ?\& (setq c + (aref newtext + (setq pos (1+ pos))))) + (substring string + (match-beginning 0) + (match-end 0))) + ((and (>= c ?1) (<= c ?9)) + ;; return empty string if N'th + ;; sub-regexp did not match: + (let ((n (- c ?0))) + (if (match-beginning n) + (substring string + (match-beginning n) + (match-end n)) + ""))) + (t + (char-to-string c))) + (char-to-string c))))) + (setq pos (1+ pos))) + expanded-newtext)) + +(defun dired-in-this-tree (file dir) + ;;Is FILE part of the directory tree starting at DIR? + (let ((len (length dir))) + (and (>= (length file) len) + (string-equal (substring file 0 len) dir)))) + +(defun dired-tree-lessp (dir1 dir2) + ;; Lexicographic order on pathname components, like `ls -lR': + ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, + ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, + ;; or DIR1 and DIR2 are in the same parentdir and their last + ;; components are string-lessp. + ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. + ;; string-lessp could arguably be replaced by file-newer-than-file-p + ;; if dired-internal-switches contained `t'. + (let ((dir1 (file-name-as-directory dir1)) + (dir2 (file-name-as-directory dir2)) + (start1 1) + (start2 1) + comp1 comp2 end1 end2) + (while (progn + (setq end1 (string-match "/" dir1 start1) + comp1 (substring dir1 start1 end1) + end2 (string-match "/" dir2 start2) + comp2 (substring dir2 start2 end2)) + (and end1 end2 (string-equal comp1 comp2))) + (setq start1 (1+ end1) + start2 (1+ end2))) + (if (eq (null end1) (null end2)) + (string-lessp comp1 comp2) + (null end1)))) + +;; So that we can support case-insensitive systems. +(fset 'dired-file-name-lessp 'string-lessp) + + +;;;; ------------------------------------------------------------------ +;;;; Initializing Dired +;;;; ------------------------------------------------------------------ + +;;; Set the minor mode alist + +(or (equal (assq 'dired-sort-mode minor-mode-alist) + '(dired-sort-mode dired-sort-mode)) + ;; Test whether this has already been done in case dired is reloaded + ;; There may be several elements with dired-sort-mode as car. + (setq minor-mode-alist + ;; cons " Omit" in first, so that it doesn't + ;; get stuck between the directory and sort mode on the + ;; mode line. + (cons '(dired-sort-mode dired-sort-mode) + (cons '(dired-subdir-omit " Omit") + (cons '(dired-marker-stack dired-marker-string) + minor-mode-alist))))) + +;;; Keymaps + +(defvar dired-mode-map nil + "Local keymap for dired-mode buffers.") +(defvar dired-regexp-map nil + "Dired keymap for commands that use regular expressions.") +(defvar dired-diff-map nil + "Dired keymap for diff and related commands.") +(defvar dired-subdir-map nil + "Dired keymap for commands that act on subdirs, or the files within them.") + +(defvar dired-keymap-grokked nil + "Set to t after dired has grokked the global keymap.") + +(defun dired-key-description (cmd &rest prefixes) + ;; Return a key description string for a menu. If prefixes are given, + ;; they should be either strings, integers, or 'universal-argument. + (let ((key (where-is-internal cmd dired-mode-map t))) + (if key + (key-description + (apply 'vconcat + (append + (mapcar + (function + (lambda (x) + (cond ((eq x 'universal-argument) + (where-is-internal 'universal-argument + dired-mode-map t)) + ((integerp x) (int-to-string x)) + (t x)))) + prefixes) + (list key)))) + ""))) + +(defun dired-grok-keys (to-command from-command) + ;; Assigns to TO-COMMAND the keys for the global binding of FROM-COMMAND. + ;; Does not clobber anything in the local keymap. In emacs 19 should + ;; use substitute-key-definition, but I believe that this will + ;; clobber things in the local map. + (let ((keys (where-is-internal from-command))) + (while keys + (condition-case nil + (if (eq (global-key-binding (car keys)) (key-binding (car keys))) + (local-set-key (car keys) to-command)) + (error nil)) + (setq keys (cdr keys))))) + +(defun dired-grok-keymap () + ;; Initialize the dired keymaps. + ;; This is actually done the first time that dired-mode runs. + ;; We do it this late, to be sure that the user's global-keymap has + ;; stabilized. + (if dired-keymap-grokked + () ; we've done it + ;; Watch out for dired being invoked from the command line. + ;; This is a bit kludgy, but so is the emacs startup sequence IMHO. + (if (and term-setup-hook (boundp 'command-line-args-left)) + (progn + (if (string-equal "18." (substring emacs-version 0 3)) + (funcall term-setup-hook) + (run-hooks 'term-setup-hook)) + (setq term-setup-hook nil))) + (setq dired-keymap-grokked t) + (run-hooks 'dired-setup-keys-hook) + (dired-grok-keys 'dired-next-line 'next-line) + (dired-grok-keys 'dired-previous-line 'previous-line) + (dired-grok-keys 'dired-undo 'undo) + (dired-grok-keys 'dired-undo 'advertised-undo) + (dired-grok-keys 'dired-scroll-up 'scroll-up) + (dired-grok-keys 'dired-scroll-down 'scroll-down) + (dired-grok-keys 'dired-beginning-of-buffer 'beginning-of-buffer) + (dired-grok-keys 'dired-end-of-buffer 'end-of-buffer) + (dired-grok-keys 'dired-next-subdir 'forward-paragraph) + (dired-grok-keys 'dired-prev-subdir 'backward-paragraph))) + +;; The regexp-map is used for commands using regexp's. +(if dired-regexp-map + () + (setq dired-regexp-map (make-sparse-keymap)) + (define-key dired-regexp-map "C" 'dired-do-copy-regexp) + ;; Not really a regexp, but does transform file names. + (define-key dired-regexp-map "D" 'dired-downcase) + (define-key dired-regexp-map "H" 'dired-do-hardlink-regexp) + (define-key dired-regexp-map "R" 'dired-do-rename-regexp) + (define-key dired-regexp-map "S" 'dired-do-symlink-regexp) + (define-key dired-regexp-map "U" 'dired-upcase) + (define-key dired-regexp-map "Y" 'dired-do-relsymlink-regexp) + (define-key dired-regexp-map "c" 'dired-cleanup) + (define-key dired-regexp-map "d" 'dired-flag-files-regexp) + (define-key dired-regexp-map "e" 'dired-mark-extension) + (define-key dired-regexp-map "m" 'dired-mark-files-regexp) + (define-key dired-regexp-map "o" 'dired-add-omit-regexp) + (define-key dired-regexp-map "x" 'dired-flag-extension)) ; a string, rather + ; than a regexp. + +(if dired-diff-map + () + (setq dired-diff-map (make-sparse-keymap)) + (define-key dired-diff-map "d" 'dired-diff) + (define-key dired-diff-map "b" 'dired-backup-diff) + (define-key dired-diff-map "m" 'dired-emerge) + (define-key dired-diff-map "a" 'dired-emerge-with-ancestor) + (define-key dired-diff-map "e" 'dired-ediff) + (define-key dired-diff-map "p" 'dired-epatch)) + +(if dired-subdir-map + () + (setq dired-subdir-map (make-sparse-keymap)) + (define-key dired-subdir-map "n" 'dired-redisplay-subdir) + (define-key dired-subdir-map "m" 'dired-mark-subdir-files) + (define-key dired-subdir-map "d" 'dired-flag-subdir-files) + (define-key dired-subdir-map "z" 'dired-compress-subdir-files)) + +(fset 'dired-regexp-prefix dired-regexp-map) +(fset 'dired-diff-prefix dired-diff-map) +(fset 'dired-subdir-prefix dired-subdir-map) +(fset 'efs-dired-prefix (function (lambda () + (interactive) + (error "efs-dired not loaded yet")))) + +;; the main map +(if dired-mode-map + nil + ;; Force `f' rather than `e' in the mode doc: + (fset 'dired-advertised-find-file 'dired-find-file) + (fset 'dired-advertised-next-subdir 'dired-next-subdir) + (fset 'dired-advertised-prev-subdir 'dired-prev-subdir) + (setq dired-mode-map (make-keymap)) + (suppress-keymap dired-mode-map) + ;; Commands to mark certain categories of files + (define-key dired-mode-map "~" 'dired-flag-backup-files) + (define-key dired-mode-map "#" 'dired-flag-auto-save-files) + (define-key dired-mode-map "*" 'dired-mark-executables) + (define-key dired-mode-map "." 'dired-clean-directory) + (define-key dired-mode-map "/" 'dired-mark-directories) + (define-key dired-mode-map "@" 'dired-mark-symlinks) + (define-key dired-mode-map "," 'dired-mark-rcs-files) + (define-key dired-mode-map "\M-(" 'dired-mark-sexp) + (define-key dired-mode-map "\M-d" 'dired-mark-files-from-other-dired-buffer) + (define-key dired-mode-map "\M-c" 'dired-mark-files-compilation-buffer) + ;; Upper case keys (except ! and &) for operating on the marked files + (define-key dired-mode-map "A" 'dired-do-tags-search) + (define-key dired-mode-map "B" 'dired-do-byte-compile) + (define-key dired-mode-map "C" 'dired-do-copy) + (define-key dired-mode-map "E" 'dired-do-grep) + (define-key dired-mode-map "F" 'dired-do-find-file) + (define-key dired-mode-map "G" 'dired-do-chgrp) + (define-key dired-mode-map "H" 'dired-do-hardlink) + (define-key dired-mode-map "I" 'dired-do-insert-subdir) + (define-key dired-mode-map "K" 'dired-do-kill-file-lines) + (define-key dired-mode-map "L" 'dired-do-load) + (define-key dired-mode-map "M" 'dired-do-chmod) + (define-key dired-mode-map "N" 'dired-do-redisplay) + (define-key dired-mode-map "O" 'dired-do-chown) + (define-key dired-mode-map "P" 'dired-do-print) + (define-key dired-mode-map "Q" 'dired-do-tags-query-replace) + (define-key dired-mode-map "R" 'dired-do-rename) + (define-key dired-mode-map "S" 'dired-do-symlink) + (define-key dired-mode-map "T" 'dired-do-total-size) + (define-key dired-mode-map "U" 'dired-do-uucode) + (define-key dired-mode-map "W" 'dired-copy-filenames-as-kill) + (define-key dired-mode-map "X" 'dired-do-delete) + (define-key dired-mode-map "Y" 'dired-do-relsymlink) + (define-key dired-mode-map "Z" 'dired-do-compress) + (define-key dired-mode-map "!" 'dired-do-shell-command) + (define-key dired-mode-map "&" 'dired-do-background-shell-command) + ;; Make all regexp commands share a `%' prefix: + (define-key dired-mode-map "%" 'dired-regexp-prefix) + ;; Lower keys for commands not operating on all the marked files + (define-key dired-mode-map "a" 'dired-apropos) + (define-key dired-mode-map "c" 'dired-change-marks) + (define-key dired-mode-map "d" 'dired-flag-file-deletion) + (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion-backup) + (define-key dired-mode-map "e" 'dired-find-file) + (define-key dired-mode-map "f" 'dired-advertised-find-file) + (define-key dired-mode-map "g" 'revert-buffer) + (define-key dired-mode-map "h" 'dired-describe-mode) + (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) + (define-key dired-mode-map "k" 'dired-kill-subdir) + (define-key dired-mode-map "m" 'dired-mark) + (define-key dired-mode-map "o" 'dired-find-file-other-window) + (define-key dired-mode-map "q" 'dired-quit) + (define-key dired-mode-map "r" 'dired-read-mail) + (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) + (define-key dired-mode-map "t" 'dired-get-target-directory) + (define-key dired-mode-map "u" 'dired-unmark) + (define-key dired-mode-map "v" 'dired-view-file) + (define-key dired-mode-map "w" (if (fboundp 'find-file-other-frame) + 'dired-find-file-other-frame + 'dired-find-file-other-window)) + (define-key dired-mode-map "x" 'dired-expunge-deletions) + (define-key dired-mode-map "y" 'dired-why) + (define-key dired-mode-map "+" 'dired-create-directory) + (define-key dired-mode-map "`" 'dired-recover-file) + ;; dired-jump-back Should be in the global map, but put them here + ;; too anyway. + (define-key dired-mode-map "\C-x\C-j" 'dired-jump-back) + (define-key dired-mode-map "\C-x4\C-j" 'dired-jump-back-other-window) + (define-key dired-mode-map "\C-x5\C-j" 'dired-jump-back-other-frame) + ;; Comparison commands + (define-key dired-mode-map "=" 'dired-diff-prefix) + ;; moving + (define-key dired-mode-map "<" 'dired-prev-dirline) + (define-key dired-mode-map ">" 'dired-next-dirline) + (define-key dired-mode-map " " 'dired-next-line) + (define-key dired-mode-map "n" 'dired-next-line) + (define-key dired-mode-map "\C-n" 'dired-next-line) + (define-key dired-mode-map "p" 'dired-previous-line) + (define-key dired-mode-map "\C-p" 'dired-previous-line) + (define-key dired-mode-map "\C-v" 'dired-scroll-up) + (define-key dired-mode-map "\M-v" 'dired-scroll-down) + (define-key dired-mode-map "\M-<" 'dired-beginning-of-buffer) + (define-key dired-mode-map "\M->" 'dired-end-of-buffer) + ;; This is silly, I'm changing it. -sb + ;; (define-key dired-mode-map "\C-m" 'dired-goto-file) + (define-key dired-mode-map "\C-m" 'dired-advertised-find-file) + ;; motion by subdirectories + (define-key dired-mode-map "^" 'dired-up-directory) + (define-key dired-mode-map "\M-\C-u" 'dired-up-directory) + (define-key dired-mode-map "\M-\C-d" 'dired-down-directory) + (define-key dired-mode-map "\M-\C-n" 'dired-advertised-next-subdir) + (define-key dired-mode-map "\M-\C-p" 'dired-advertised-prev-subdir) + (define-key dired-mode-map "\C-j" 'dired-goto-subdir) + ;; move to marked files + (define-key dired-mode-map "\M-p" 'dired-prev-marked-file) + (define-key dired-mode-map "\M-n" 'dired-next-marked-file) + ;; hiding + (define-key dired-mode-map "$" 'dired-hide-subdir) + (define-key dired-mode-map "\M-$" 'dired-hide-all) + ;; omitting + (define-key dired-mode-map "\C-o" 'dired-omit-toggle) + ;; markers + (define-key dired-mode-map "\(" 'dired-set-marker-char) + (define-key dired-mode-map "\)" 'dired-restore-marker-char) + (define-key dired-mode-map "'" 'dired-marker-stack-left) + (define-key dired-mode-map "\\" 'dired-marker-stack-right) + ;; misc + (define-key dired-mode-map "\C-i" 'dired-mark-prefix) + (define-key dired-mode-map "?" 'dired-summary) + (define-key dired-mode-map "\177" 'dired-backup-unflag) + (define-key dired-mode-map "\C-_" 'dired-undo) + (define-key dired-mode-map "\C-xu" 'dired-undo) + (define-key dired-mode-map "\M-\C-?" 'dired-unmark-all-files) + ;; The subdir map + (define-key dired-mode-map "|" 'dired-subdir-prefix) + ;; efs submap + (define-key dired-mode-map "\M-e" 'efs-dired-prefix)) + + + +;;;;------------------------------------------------------------------ +;;;; The dired command +;;;;------------------------------------------------------------------ + +;;; User commands: +;;; All of these commands should have a binding in the global keymap. + +;;;###autoload (define-key ctl-x-map "d" 'dired) +;;;###autoload +(defun dired (dirname &optional switches) + "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Optional second argument SWITCHES specifies the `ls' options used. +\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Dired displays a list of files in DIRNAME (which may also have +shell wildcards appended to select certain files). If DIRNAME is a cons, +its first element is taken as the directory name and the resr as an explicit +list of files to make directory entries for. +\\\ +You can move around in it with the usual commands. +You can flag files for deletion with \\[dired-flag-file-deletion] and then +delete them by typing \\[dired-expunge-deletions]. +Type \\[dired-describe-mode] after entering dired for more info. + +If DIRNAME is already in a dired buffer, that buffer is used without refresh." + ;; Cannot use (interactive "D") because of wildcards. + (interactive (dired-read-dir-and-switches "")) + (switch-to-buffer (dired-noselect dirname switches))) + +;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) +;;;###autoload +(defun dired-other-window (dirname &optional switches) + "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." + (interactive (dired-read-dir-and-switches "in other window ")) + (switch-to-buffer-other-window (dired-noselect dirname switches))) + +;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) +;;;###autoload +(defun dired-other-frame (dirname &optional switches) + "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." + (interactive (dired-read-dir-and-switches "in other frame ")) + (switch-to-buffer-other-frame (dired-noselect dirname switches))) + +;;;###autoload +(defun dired-noselect (dir-or-list &optional switches) + "Like `dired' but returns the dired buffer as value, does not select it." + (or dir-or-list (setq dir-or-list (expand-file-name default-directory))) + ;; This loses the distinction between "/foo/*/" and "/foo/*" that + ;; some shells make: + (let (dirname) + (if (consp dir-or-list) + (setq dirname (car dir-or-list)) + (setq dirname dir-or-list)) + (setq dirname (expand-file-name (directory-file-name dirname))) + (if (file-directory-p dirname) + (setq dirname (file-name-as-directory dirname))) + (if (consp dir-or-list) + (setq dir-or-list (cons dirname (cdr dir-or-list))) + (setq dir-or-list dirname)) + (dired-internal-noselect dir-or-list switches))) + +;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). +;;;###autoload (define-key ctl-x-map "\C-j" 'dired-jump-back) +;;;###autoload +(defun dired-jump-back () + "Jump back to dired. +If in a file, dired the current directory and move to file's line. +If in dired already, pop up a level and goto old directory's line. +In case the proper dired file line cannot be found, refresh the dired + buffer and try again." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired dir) + (if file (dired-really-goto-file file)))) + +;;;###autoload (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) +;;;###autoload +(defun dired-jump-back-other-window () + "Like \\[dired-jump-back], but to other window." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired-other-window dir) + (if file (dired-really-goto-file file)))) + +;;;###autoload (define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) +;;;###autoload +(defun dired-jump-back-other-frame () + "Like \\[dired-jump-back], but in another frame." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired-other-frame dir) + (if file (dired-really-goto-file file)))) + +;;; Dired mode + +;; Dired mode is suitable only for specially formatted data. +(put 'dired-mode 'mode-class 'special) + +(defun dired-mode (&optional dirname switches) + "\\Dired mode is for \"editing\" directory trees. + +For a simple one-line help message, type \\[dired-summary] +For a moderately detailed description of dired mode, type \\[dired-describe-mode] +For the full dired info tree, type \\[universal-argument] \\[dired-describe-mode]" + ;; Not to be called interactively (e.g. dired-directory will be set + ;; to default-directory, which is wrong with wildcards). + (kill-all-local-variables) + (use-local-map dired-mode-map) + (setq major-mode 'dired-mode + mode-name "Dired" + case-fold-search nil + buffer-read-only t + selective-display t ; for subdirectory hiding + selective-display-ellipses nil ; for omit toggling + mode-line-buffer-identification '("Dired: %12b") + mode-line-modified (format dired-mode-line-modified "--" "--" "-") + dired-directory (expand-file-name (or dirname default-directory)) + dired-internal-switches (dired-make-switches-list + (or switches dired-listing-switches))) + (dired-advertise) ; default-directory is already set + (set (make-local-variable 'revert-buffer-function) + (function dired-revert)) + (set (make-local-variable 'default-directory-function) + 'dired-current-directory) + (set (make-local-variable 'page-delimiter) + "\n\n") + (set (make-local-variable 'list-buffers-directory) + dired-directory) + ;; Will only do something in Emacs 19. + (add-hook (make-local-variable 'kill-buffer-hook) + 'dired-unadvertise-current-buffer) + ;; Same here + (if window-system + (add-hook (make-local-variable 'post-command-hook) + (function + (lambda () + (if (memq this-command dired-modeline-tracking-cmds) + (dired-update-mode-line t)))))) + (dired-sort-other dired-internal-switches t) + (dired-hack-local-variables) + (run-hooks 'dired-mode-hook) + ;; Run this after dired-mode-hook, in case that hook makes changes to + ;; the keymap. + (dired-grok-keymap)) + +;;; Internal functions for starting dired + +(defun dired-read-dir-and-switches (str) + ;; For use in interactive. + (reverse (list + (if current-prefix-arg + (read-string "Dired listing switches: " + dired-listing-switches)) + (let ((default-directory (default-directory))) + (read-file-name (format "Dired %s(directory): " str) + nil default-directory nil))))) + +(defun dired-hack-local-variables () + "Parse, bind or evaluate any local variables for current dired buffer. +See variable `dired-local-variables-file'." + (if (and dired-local-variables-file + (file-exists-p dired-local-variables-file)) + (let (buffer-read-only opoint ) + (save-excursion + (goto-char (point-max)) + (setq opoint (point-marker)) + (insert "\^L\n") + (insert-file-contents dired-local-variables-file)) + (let ((buffer-file-name dired-local-variables-file)) + (condition-case err + (hack-local-variables) + (error (message "Error in dired-local-variables-file: %s" err) + (sit-for 1)))) + ;; Must delete it as (eobp) is often used as test for last + ;; subdir in dired.el. + (delete-region opoint (point-max)) + (set-marker opoint nil)))) + +;; Separate function from dired-noselect for the sake of dired-vms.el. +(defun dired-internal-noselect (dir-or-list &optional switches mode) + ;; If there is an existing dired buffer for DIRNAME, just leave + ;; buffer as it is (don't even call dired-revert). + ;; This saves time especially for deep trees or with efs. + ;; The user can type `g'easily, and it is more consistent with find-file. + ;; But if SWITCHES are given they are probably different from the + ;; buffer's old value, so call dired-sort-other, which does + ;; revert the buffer. + ;; If the user specifies a directory with emacs startup, eg. + ;; emacs ~, dir-or-list may be unexpanded at this point. + + (let* ((dirname (expand-file-name (if (consp dir-or-list) + (car dir-or-list) + dir-or-list))) + (buffer (dired-find-buffer-nocreate dir-or-list mode)) + ;; note that buffer already is in dired-mode, if found + (new-buffer-p (not buffer)) + (old-buf (current-buffer)) + wildcard) + (or buffer + (let ((default-major-mode 'fundamental-mode)) + ;; We don't want default-major-mode to run hooks and set auto-fill + ;; or whatever, now that dired-mode does not + ;; kill-all-local-variables any longer. + (setq buffer (create-file-buffer (directory-file-name dirname))))) + (set-buffer buffer) + (if (not new-buffer-p) ; existing buffer ... + (progn + (if switches + (dired-sort-other + (if (stringp switches) + (dired-make-switches-list switches) + switches))) + (if dired-verify-modtimes (dired-verify-modtimes)) + (if (and dired-find-subdir + (not (string-equal (dired-current-directory) + (file-name-as-directory dirname)))) + (dired-initial-position dirname))) + ;; Else a new buffer + (if (file-directory-p dirname) + (setq default-directory dirname + wildcard (consp dir-or-list)) + (setq default-directory (file-name-directory dirname) + wildcard t)) + (or switches (setq switches dired-listing-switches)) + (dired-mode dirname switches) + ;; default-directory and dired-internal-switches are set now + ;; (buffer-local), so we can call dired-readin: + (let ((failed t)) + (unwind-protect + (progn (dired-readin dir-or-list buffer wildcard) + (setq failed nil)) + ;; dired-readin can fail if parent directories are inaccessible. + ;; Don't leave an empty buffer around in that case. + (if failed (kill-buffer buffer)))) + ;; No need to narrow since the whole buffer contains just + ;; dired-readin's output, nothing else. The hook can + ;; successfully use dired functions (e.g. dired-get-filename) + ;; as the subdir-alist has been built in dired-readin. + (run-hooks 'dired-after-readin-hook) + ;; I put omit-expunge after the dired-after-readin-hook + ;; in case that hook marks files. Does this make sense? Also, users + ;; might want to set dired-omit-files-p in some incredibly clever + ;; way depending on the contents of the directory... I don't know... + (if dired-omit-files + (dired-omit-expunge nil t)) + (goto-char (point-min)) + (dired-initial-position dirname)) + (set-buffer old-buf) + buffer)) + +(defun dired-find-buffer-nocreate (dir-or-list &optional mode) + ;; Returns a dired buffer for DIR-OR-LIST. DIR-OR-LIST may be wildcard, + ;; or a directory and alist of files. + ;; If dired-find-subdir is non-nil, is satisfied with a dired + ;; buffer containing DIR-OR-LIST as a subdirectory. If there is more + ;; than one candidate, returns the most recently used. + (if dired-find-subdir + (let ((buffers (sort (delq (current-buffer) + (dired-buffers-for-dir dir-or-list t)) + (function dired-buffer-more-recently-used-p)))) + (or (car buffers) + ;; Couldn't find another buffer. Will the current one do? + ;; It is up dired-initial-position to actually go to the subdir. + (and (or (equal dir-or-list dired-directory) ; covers wildcards + (and (stringp dir-or-list) + (not (string-equal + dir-or-list + (expand-file-name default-directory))) + (assoc (file-name-as-directory dir-or-list) + dired-subdir-alist))) + (current-buffer)))) + ;; Else just look through the buffer list. + (let (found (blist (buffer-list))) + (or mode (setq mode 'dired-mode)) + (save-excursion + (while blist + (set-buffer (car blist)) + (if (and (eq major-mode mode) + (equal dired-directory dir-or-list)) + (setq found (car blist) + blist nil) + (setq blist (cdr blist))))) + found))) + +(defun dired-initial-position (dirname) + ;; Where point should go in a new listing of DIRNAME. + ;; Point assumed at beginning of new subdir line. + (end-of-line) + (if dired-find-subdir (dired-goto-subdir dirname)) + (if dired-trivial-filenames (dired-goto-next-nontrivial-file)) + (dired-update-mode-line t)) + +(defun dired-readin (dir-or-list buffer &optional wildcard) + ;; Read in a new dired buffer + ;; dired-readin differs from dired-insert-subdir in that it accepts + ;; wildcards, erases the buffer, and builds the subdir-alist anew + ;; (including making it buffer-local and clearing it first). + ;; default-directory and dired-internal-switches must be buffer-local + ;; and initialized by now. + ;; Thus we can test (equal default-directory dirname) instead of + ;; (file-directory-p dirname) and save a filesystem transaction. + ;; This is wrong, if dired-before-readin-hook changes default-directory + ;; Also, we can run this hook which may want to modify the switches + ;; based on default-directory, e.g. with efs to a SysV host + ;; where ls won't understand -Al switches. + (let (dirname other-dirs) + (if (consp dir-or-list) + (setq dir-or-list (dired-frob-dir-list dir-or-list) + other-dirs (cdr dir-or-list) + dir-or-list (car dir-or-list) + dirname (car dir-or-list)) + (setq dirname dir-or-list)) + (setq dirname (expand-file-name dirname)) + (if (consp dir-or-list) + (setq dir-or-list (cons dirname (cdr dir-or-list)))) + (save-excursion + (set-buffer buffer) + (run-hooks 'dired-before-readin-hook) + (message "Reading directory %s..." dirname) + (let (buffer-read-only) + (widen) + (erase-buffer) + (dired-readin-insert dir-or-list wildcard) + (dired-indent-listing (point-min) (point-max)) + ;; We need this to make the root dir have a header line as all + ;; other subdirs have: + (goto-char (point-min)) + (dired-insert-headerline (expand-file-name default-directory))) + (message "Reading directory %s...done" dirname) + (set-buffer-modified-p nil) + ;; Must first make alist buffer local and set it to nil because + ;; dired-build-subdir-alist will call dired-clear-alist first + (setq dired-subdir-alist nil) + (if (memq ?R dired-internal-switches) + (dired-build-subdir-alist) + ;; no need to parse the buffer if listing is not recursive + (dired-simple-subdir-alist)) + (if other-dirs + (mapcar + (function + (lambda (x) + (if (dired-in-this-tree (car x) dirname) + (dired-insert-subdir x)))) + other-dirs))))) + +;;; Subroutines of dired-readin + +(defun dired-readin-insert (dir-or-list &optional wildcard) + ;; Just insert listing for the passed-in directory or + ;; directory-and-file list, assuming a clean buffer. + (let* ((switches (dired-make-switches-string dired-internal-switches)) + (dir-is-list (consp dir-or-list)) + (dirname (if dir-is-list (car dir-or-list) dir-or-list))) + (if wildcard + (progn + (or (file-readable-p + (if dir-is-list + dirname + (directory-file-name (file-name-directory dirname)))) + (error "Directory %s inaccessible or nonexistent" dirname)) + ;; else assume it contains wildcards + (dired-insert-directory dir-or-list switches t) + (save-excursion + ;; insert wildcard instead of total line: + (goto-char (point-min)) + (if dir-is-list + (insert "list wildcard\n") + (insert "wildcard " (file-name-nondirectory dirname) "\n")))) + (dired-insert-directory dir-or-list switches nil t)))) + +(defun dired-insert-directory (dir-or-list switches &optional wildcard full-p) + ;; Do the right thing whether dir-or-list is atomic or not. If it is, + ;; insert all files listed in the cdr -- the car is the passed-in directory + ;; list. + (let ((opoint (point)) + (insert-directory-program dired-ls-program)) + (if (consp dir-or-list) + (mapcar + (function + (lambda (x) + (insert-directory x switches wildcard))) + (cdr dir-or-list)) + (insert-directory dir-or-list switches wildcard full-p)) + (dired-insert-set-properties opoint (point))) + (setq dired-directory dir-or-list)) + +(defun dired-frob-dir-list (dir-list) + (let* ((top (file-name-as-directory (expand-file-name (car dir-list)))) + (tail (cdr dir-list)) + (result (list (list top))) + elt dir) + (setq tail + (mapcar + (function + (lambda (x) + (directory-file-name (expand-file-name x top)))) + tail)) + (while tail + (setq dir (file-name-directory (car tail))) + (if (setq elt (assoc dir result)) + (nconc elt (list (car tail))) + (nconc result (list (list dir (car tail))))) + (setq tail (cdr tail))) + result)) + +(defun dired-insert-headerline (dir);; also used by dired-insert-subdir + ;; Insert DIR's headerline with no trailing slash, exactly like ls + ;; would, and put cursor where dired-build-subdir-alist puts subdir + ;; boundaries. + (save-excursion (insert " " (directory-file-name dir) ":\n"))) + +(defun dired-verify-modtimes () + ;; Check the modtimes of all subdirs. + (let ((alist dired-subdir-alist) + on-disk in-mem badies) + (while alist + (and (setq in-mem (nth 4 (car alist))) + (setq on-disk (dired-file-modtime (car (car alist)))) + (not (equal in-mem on-disk)) + (setq badies (cons (cons (car (car alist)) + (nth 3 (car alist))) + badies))) + (setq alist (cdr alist))) + (and badies + (let* ((ofile (dired-get-filename nil t)) + (osub (and (null ofile) (dired-get-subdir))) + (opoint (point)) + (ocol (current-column))) + (unwind-protect + (and + (or (memq 'revert-subdirs dired-no-confirm) + (save-window-excursion + (let ((flist (mapcar + (function + (lambda (f) + (dired-abbreviate-file-name (car f)))) + badies))) + (switch-to-buffer (current-buffer)) + (dired-mark-pop-up + "*Stale Subdirectories*" 'revert-subdirs + flist 'y-or-n-p + (if (= (length flist) 1) + (concat "Subdirectory " (car flist) + " has changed on disk. Re-list? ") + "Subdirectories have changed on disk. Re-list? ")) + ))) + (while badies + (dired-insert-subdir (car (car badies)) + (cdr (car badies)) nil t) + (setq badies (cdr badies)))) + ;; We can't use dired-save-excursion here, because we are + ;; rewriting the entire listing, and not just changing a single + ;; file line. + (or (if ofile + (dired-goto-file ofile) + (if osub + (dired-goto-subdir osub))) + (progn + (goto-char opoint) + (beginning-of-line) + (skip-chars-forward "^\n\r" (+ (point) ocol)))) + (dired-update-mode-line t) + (dired-update-mode-line-modified t)))))) + +(defun dired-indent-listing (start end) + ;; Indent a dired listing. + (let (indent-tabs-mode) + (indent-rigidly start end 2) + ;; Quote any null lines that shouldn't be. + (save-excursion + (goto-char start) + (while (search-forward "\n\n" end t) + (forward-char -2) + (if (looking-at dired-subdir-regexp) + (goto-char (match-end 3)) + (progn + (forward-char 1) + (insert " "))))))) + + +;;;; ------------------------------------------------------------ +;;;; Reverting a dired buffer, or specific file lines within it. +;;;; ------------------------------------------------------------ + +(defun dired-revert (&optional arg noconfirm) + ;; Reread the dired buffer. Must also be called after + ;; dired-internal-switches have changed. + ;; Should not fail even on completely garbaged buffers. + ;; Preserves old cursor, marks/flags, hidden-p. + (widen) ; just in case user narrowed + (let ((opoint (point)) + (ofile (dired-get-filename nil t)) + (hidden-subdirs (dired-remember-hidden)) + ;; switches for top-level dir + (oswitches (or (nth 3 (nth (1- (length dired-subdir-alist)) + dired-subdir-alist)) + (delq ?R (copy-sequence dired-internal-switches)))) + ;; all other subdirs + (old-subdir-alist (cdr (reverse dired-subdir-alist))) + (omitted-subdirs (dired-remember-omitted)) + ;; do this after dired-remember-hidden, since this unhides + (mark-alist (dired-remember-marks (point-min) (point-max))) + (kill-files-p (save-excursion + (goto-char (point)) + (search-forward + (concat (char-to-string ?\r) + (regexp-quote + (char-to-string + dired-kill-marker-char))) + nil t))) + buffer-read-only) + ;; This is bogus, as it will not handle all the ways that efs uses cache. + ;; Better to just use the fact that revert-buffer-function is a + ;; buffer-local variable, and reset it to something that knows about + ;; cache. + ;; (dired-uncache + ;; (if (consp dired-directory) (car dired-directory) dired-directory)) + ;; treat top level dir extra (it may contain wildcards) + (let ((dired-after-readin-hook nil) + ;; don't run that hook for each subdir... + (dired-omit-files nil) + (dired-internal-switches oswitches)) + (dired-readin dired-directory (current-buffer) + ;; Don't test for wildcards by checking string= + ;; default-directory and dired-directory + ;; in case default-directory got munged. + (or (consp dired-directory) + (null (file-directory-p dired-directory)))) + ;; The R-switch will clobber sorting of subdirs. + ;; What is the right thing to do here? + (dired-insert-old-subdirs old-subdir-alist)) + (dired-mark-remembered mark-alist) ; mark files that were marked + (if kill-files-p (dired-do-hide dired-kill-marker-char)) + (run-hooks 'dired-after-readin-hook) ; no need to narrow + ;; omit-expunge after the readin hook + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-omit-expunge)))) + omitted-subdirs)) + ;; hide subdirs that were hidden + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + ;; Try to get back to where we were + (or (and ofile (dired-goto-file ofile)) + (goto-char opoint)) + (dired-move-to-filename) + (dired-update-mode-line t) + (dired-update-mode-line-modified t))) + +(defun dired-do-redisplay (&optional arg) + "Redisplay all marked (or next ARG) files." + (interactive "P") + ;; message instead of making dired-map-over-marks show-progress is + ;; much faster + (dired-map-over-marks (let ((fname (dired-get-filename))) + (dired-uncache fname nil) + (message "Redisplaying %s..." fname) + (dired-update-file-line fname)) + arg) + (dired-update-mode-line-modified t) + (message "Redisplaying...done")) + +(defun dired-redisplay-subdir (&optional arg) + "Redisplay the current subdirectory. +With a prefix prompts for listing switches." + (interactive "P") + (let ((switches (and arg (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches))))) + (dir (dired-current-directory)) + (opoint (point)) + (ofile (dired-get-filename nil t))) + (or switches + (setq switches (nth 3 (assoc dir dired-subdir-alist)))) + (or switches + (setq switches (delq ?R (copy-sequence dired-internal-switches)))) + (message "Redisplaying %s..." dir) + (dired-uncache dir t) + (dired-insert-subdir dir switches) + (dired-update-mode-line-modified t) + (or (and ofile (dired-goto-file ofile)) (goto-char opoint)) + (message "Redisplaying %s... done" dir))) + +(defun dired-update-file-line (file) + ;; Delete the current line, and insert an entry for FILE. + ;; Does not update other dired buffers. Use dired-relist-file for that. + (let* ((start (save-excursion (skip-chars-backward "^\n\r") (point))) + (char (char-after start))) + (dired-save-excursion + ;; don't remember omit marks + (if (memq char (list ?\040 dired-omit-marker-char)) + (setq char nil)) + ;; Delete the current-line. Even though dired-add-entry will not + ;; insert duplicates, the file for the current line may not be the same as + ;; FILE. eg. dired-do-compress + (delete-region (save-excursion (skip-chars-backward "^\n\r") (1- (point))) + (progn (skip-chars-forward "^\n\r") (point))) + ;; dired-add-entry inserts at the end of the previous line. + (forward-char 1) + (dired-add-entry file char t)))) + +;;; Subroutines of dired-revert +;;; Some of these are also used when inserting subdirs. + +;; Don't want to remember omit marks, in case omission regexps +;; were changed, before the dired-revert. If we don't unhide +;; omitted files, we won't see their marks. Therefore we use +;; dired-omit-unhide-region. + +(defun dired-remember-marks (beg end) + ;; Return alist of files and their marks, from BEG to END. + (if selective-display ; must unhide to make this work. + (let (buffer-read-only) + (subst-char-in-region (point-min) (point-max) ?\r ?\n) + (dired-do-hide dired-omit-marker-char))) + (let (fil chr alist) + (save-excursion + (goto-char beg) + (while (re-search-forward dired-re-mark end t) + (if (setq fil (dired-get-filename nil t)) + (setq chr (preceding-char) + alist (cons (cons fil chr) alist))))) + alist)) + +(defun dired-mark-remembered (alist) + ;; Mark all files remembered in ALIST. + (let (elt fil chr) + (while alist + (setq elt (car alist) + alist (cdr alist) + fil (car elt) + chr (cdr elt)) + (if (dired-goto-file fil) + (save-excursion + (beginning-of-line) + (dired-substitute-marker (point) (following-char) chr)))))) + +(defun dired-remember-hidden () + ;; Return a list of all hidden subdirs. + (let ((l dired-subdir-alist) dir result min) + (while l + (setq dir (car (car l)) + min (dired-get-subdir-min (car l)) + l (cdr l)) + (if (and (>= min (point-min)) (<= min (point-max)) + (dired-subdir-hidden-p dir)) + (setq result (cons dir result)))) + result)) + +(defun dired-insert-old-subdirs (old-subdir-alist) + ;; Try to insert all subdirs that were displayed before + (let (elt dir switches) + (while old-subdir-alist + (setq elt (car old-subdir-alist) + old-subdir-alist (cdr old-subdir-alist) + dir (car elt) + switches (or (nth 3 elt) dired-internal-switches)) + (condition-case () + (dired-insert-subdir dir switches) + (error nil))))) + +(defun dired-uncache (file dir-p) + ;; Remove directory DIR from any directory cache. + ;; If DIR-P is non-nil, then FILE is a directory + (let ((handler (find-file-name-handler file 'dired-uncache))) + (if handler + (funcall handler 'dired-uncache file dir-p)))) + + +;;;; ------------------------------------------------------------- +;;;; Inserting subdirectories +;;;; ------------------------------------------------------------- + +(defun dired-maybe-insert-subdir (dirname &optional + switches no-error-if-not-dir-p) + "Insert this subdirectory into the same dired buffer. +If it is already present, just move to it (type \\[dired-do-redisplay] to + refresh), else inserts it at its natural place (as ls -lR would have done). +With a prefix arg, you may edit the ls switches used for this listing. + You can add `R' to the switches to expand the whole tree starting at + this subdirectory. +This function takes some pains to conform to ls -lR output." + (interactive + (list (dired-get-filename) + (if current-prefix-arg + (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches)))))) + (let ((opoint (point))) + ;; We don't need a marker for opoint as the subdir is always + ;; inserted *after* opoint. + (setq dirname (file-name-as-directory dirname)) + (or (and (not switches) + (dired-goto-subdir dirname)) + (dired-insert-subdir dirname switches no-error-if-not-dir-p)) + ;; Push mark so that it's easy to find back. Do this after the + ;; insert message so that the user sees the `Mark set' message. + (push-mark opoint))) + +(defun dired-insert-subdir (dir-or-list &optional + switches no-error-if-not-dir-p no-posn) + "Insert this subdirectory into the same dired buffer. +If it is already present, overwrites previous entry, + else inserts it at its natural place (as ls -lR would have done). +With a prefix arg, you may edit the ls switches used for this listing. + You can add `R' to the switches to expand the whole tree starting at + this subdirectory. +This function takes some pains to conform to ls -lR output." + ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like + ;; Prospero where dired-ls does the right thing, but + ;; file-directory-p has not been redefined. + ;; SWITCHES should be a list. + ;; If NO-POSN is non-nil, doesn't bother position the point at + ;; the first nontrivial file line. This can be used as an efficiency + ;; hack when calling this from a program. + (interactive + (list (dired-get-filename) + (if current-prefix-arg + (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches)))))) + (let ((dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list))) + (setq dirname (file-name-as-directory (expand-file-name dirname))) + (or (dired-in-this-tree dirname (expand-file-name default-directory)) + (error "%s: not in this directory tree" dirname)) + (or no-error-if-not-dir-p + (file-directory-p dirname) + (error "Attempt to insert a non-directory: %s" dirname)) + (if switches + (or (dired-compatible-switches-p dired-internal-switches switches) + (error "Cannot have subdirs with %s and %s switches together." + (dired-make-switches-string dired-internal-switches) + (dired-make-switches-string switches))) + (setq switches dired-internal-switches)) + (let ((elt (assoc dirname dired-subdir-alist)) + mark-alist opoint-max buffer-read-only) + (if (memq ?R switches) + ;; avoid duplicated subdirs + (progn + (setq mark-alist (dired-kill-tree dirname t)) + (dired-insert-subdir-newpos dirname)) + (if elt + ;; If subdir is already present, remove it and remember its marks + (setq mark-alist (dired-insert-subdir-del elt)) + ;; else move to new position + (dired-insert-subdir-newpos dirname))) + (setq opoint-max (point-max)) + (condition-case nil + (dired-insert-subdir-doupdate + dirname (dired-insert-subdir-doinsert dir-or-list switches) + switches elt mark-alist) + (quit ; watch out for aborted inserts + (and (= opoint-max (point-max)) + (null elt) + (= (preceding-char) ?\n) + (delete-char -1)) + (signal 'quit nil)))) + (or no-posn (dired-initial-position dirname)))) + +(defun dired-do-insert-subdir () + "Insert all marked subdirectories in situ that are not yet inserted. +Non-directories are silently ignored." + (interactive) + (let ((files (or (dired-get-marked-files) + (error "No files marked.")))) + (while files + (if (file-directory-p (car files)) + (save-excursion (dired-maybe-insert-subdir (car files)))) + (setq files (cdr files))))) + +;;; Utilities for inserting subdirectories + +(defun dired-insert-subdir-newpos (new-dir) + ;; Find pos for new subdir, according to tree order. + (let ((alist dired-subdir-alist) elt dir new-pos) + (while alist + (setq elt (car alist) + alist (cdr alist) + dir (car elt)) + (if (dired-tree-lessp dir new-dir) + ;; Insert NEW-DIR after DIR + (setq new-pos (dired-get-subdir-max elt) + alist nil))) + (goto-char new-pos)) + (insert "\n") + (point)) + +(defun dired-insert-subdir-del (element) + ;; Erase an already present subdir (given by ELEMENT) from buffer. + ;; Move to that buffer position. Return a mark-alist. + (let ((begin-marker (dired-get-subdir-min element))) + (goto-char begin-marker) + ;; Are at beginning of subdir (and inside it!). Now determine its end: + (goto-char (dired-subdir-max)) + (prog1 + (dired-remember-marks begin-marker (point)) + (delete-region begin-marker (point))))) + +(defun dired-insert-subdir-doinsert (dir-or-list switches) + ;; Insert ls output after point and put point on the correct + ;; position for the subdir alist. + ;; Return the boundary of the inserted text (as list of BEG and END). + ;; SWITCHES should be a non-nil list. + (let ((begin (point)) + (dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list)) + end) + (message "Reading directory %s..." dirname) + (if (string-equal dirname (car (car (reverse dired-subdir-alist)))) + ;; top level directory may contain wildcards: + (let ((dired-internal-switches switches)) + (dired-readin-insert dired-directory + (null (file-directory-p dired-directory)))) + (let ((switches (dired-make-switches-string switches)) + (insert-directory-program dired-ls-program)) + (if (consp dir-or-list) + (progn + (insert "list wildcard\n") + (mapcar + (function + (lambda (x) + (insert-directory x switches t))) + (cdr dir-or-list))) + (insert-directory dirname switches nil t)))) + (message "Reading directory %s...done" dirname) + (setq end (point-marker)) + (dired-indent-listing begin end) + (dired-insert-set-properties begin end) + ;; call dired-insert-headerline afterwards, as under VMS dired-ls + ;; does insert the headerline itself and the insert function just + ;; moves point. + ;; Need a marker for END as this inserts text. + (goto-char begin) + (dired-insert-headerline dirname) + ;; point is now like in dired-build-subdir-alist + (prog1 + (list begin (marker-position end)) + (set-marker end nil)))) + +(defun dired-insert-subdir-doupdate (dirname beg-end switches elt mark-alist) + ;; Point is at the correct subdir alist position for ELT, + ;; BEG-END is the subdir-region (as list of begin and end). + ;; SWITCHES must be a non-nil list. + (if (memq ?R switches) + ;; This will remove ?R from switches on purpose. + (let ((dired-internal-switches (delq ?R switches))) + (dired-build-subdir-alist)) + (if elt + (progn + (set-marker (dired-get-subdir-min elt) (point-marker)) + (setcar (nthcdr 3 elt) switches) + (if dired-verify-modtimes + (dired-set-file-modtime dirname dired-subdir-alist))) + (dired-alist-add dirname (point-marker) dired-omit-files switches))) + (save-excursion + (let ((begin (nth 0 beg-end)) + (end (nth 1 beg-end))) + (goto-char begin) + (save-restriction + (narrow-to-region begin end) + ;; hook may add or delete lines, but the subdir boundary + ;; marker floats + (run-hooks 'dired-after-readin-hook) + (if mark-alist (dired-mark-remembered mark-alist)) + (dired-do-hide dired-kill-marker-char) + (if (if elt (nth 2 elt) dired-omit-files) + (dired-omit-expunge nil t)))))) + + +;;;; -------------------------------------------------------------- +;;;; Dired motion commands -- moving around in the dired buffer. +;;;; -------------------------------------------------------------- + +(defun dired-next-line (arg) + "Move down lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (condition-case err + (next-line arg) + (error + (if (eobp) + (error "End of buffer") + (error "%s" err)))) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-previous-line (arg) + "Move up lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (previous-line arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-scroll-up (arg) + "Dired version of scroll up. +Scroll text of current window upward ARG lines; or near full screen if no ARG. +When calling from a program, supply a number as argument or nil." + (interactive "P") + (scroll-up arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-scroll-down (arg) + "Dired version of scroll-down. +Scroll text of current window down ARG lines; or near full screen if no ARG. +When calling from a program, supply a number as argument or nil." + (interactive "P") + (scroll-down arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-beginning-of-buffer (arg) + "Dired version of `beginning of buffer'." + (interactive "P") + (beginning-of-buffer arg) + (dired-update-mode-line)) + +(defun dired-end-of-buffer (arg) + "Dired version of `end-of-buffer'." + (interactive "P") + (end-of-buffer arg) + (while (not (or (dired-move-to-filename) (dired-get-subdir) (bobp))) + (forward-line -1)) + (dired-update-mode-line t)) + +(defun dired-next-dirline (arg &optional opoint) + "Goto ARG'th next directory file line." + (interactive "p") + (if dired-re-dir + (progn + (dired-check-ls-l) + (or opoint (setq opoint (point))) + (if (if (> arg 0) + (re-search-forward dired-re-dir nil t arg) + (beginning-of-line) + (re-search-backward dired-re-dir nil t (- arg))) + (progn + (dired-move-to-filename) ; user may type `i' or `f' + (dired-update-mode-line)) + (goto-char opoint) + (error "No more subdirectories"))))) + +(defun dired-prev-dirline (arg) + "Goto ARG'th previous directory file line." + (interactive "p") + (dired-next-dirline (- arg))) + +(defun dired-next-marked-file (arg &optional wrap opoint) + "Move to the next marked file, wrapping around the end of the buffer." + (interactive "p\np") + (or opoint (setq opoint (point))) ; return to where interactively started + (if (if (> arg 0) + (re-search-forward dired-re-mark nil t arg) + (beginning-of-line) + (re-search-backward dired-re-mark nil t (- arg))) + (dired-move-to-filename) + (if (null wrap) + (progn + (goto-char opoint) + (error "No next marked file")) + (message "(Wraparound for next marked file)") + (goto-char (if (> arg 0) (point-min) (point-max))) + (dired-next-marked-file arg nil opoint))) + (dired-update-mode-line)) + +(defun dired-prev-marked-file (arg &optional wrap) + "Move to the previous marked file, wrapping around the end of the buffer." + (interactive "p\np") + (dired-next-marked-file (- arg) wrap) + (dired-update-mode-line)) + +(defun dired-goto-file (file) + "Goto file line of FILE in this dired buffer." + ;; Return value of point on success, else nil. + ;; FILE must be an absolute pathname. + ;; Loses if FILE contains control chars like "\007" for which ls + ;; either inserts "?" or "\\007" into the buffer, so we won't find + ;; it in the buffer. + (interactive + (prog1 ; let push-mark display its message + (list + (let* ((dired-completer-buffer (current-buffer)) + (dired-completer-switches dired-internal-switches) + (stack (reverse + (mapcar (function + (lambda (x) + (dired-abbreviate-file-name (car x)))) + dired-subdir-alist))) + (initial (car stack)) + (dired-goto-file-history (cdr stack)) + dired-completer-cache) + (expand-file-name + (dired-completing-read "Goto file: " + 'dired-goto-file-completer + nil t initial 'dired-goto-file-history)))) + (push-mark))) + (setq file (directory-file-name file)) ; does no harm if no directory + (let (found case-fold-search) + (save-excursion + (if (dired-goto-subdir (or (file-name-directory file) + (error "Need absolute pathname for %s" + file))) + (let* ((base (file-name-nondirectory file)) + ;; filenames are preceded by SPC, this makes + ;; the search faster (e.g. for the filename "-"!). + (search (concat " " (dired-make-filename-string base t))) + (boundary (dired-subdir-max)) + fn) + (while (and (not found) (search-forward search boundary 'move)) + ;; Match could have BASE just as initial substring or + ;; or in permission bits or date or + ;; not be a proper filename at all: + (if (and (setq fn (dired-get-filename 'no-dir t)) + (string-equal fn base)) + ;; Must move to filename since an (actually + ;; correct) match could have been elsewhere on the + ;; line (e.g. "-" would match somewhere in the + ;; permission bits). + (setq found (dired-move-to-filename))))))) + (and found + ;; return value of point (i.e., FOUND): + (prog1 + (goto-char found) + (dired-update-mode-line))))) + +;;; Moving by subdirectories + +(defun dired-up-directory (arg) + "Move to the ARG'th (prefix arg) parent directory of current directory. +Always stays within the current tree dired buffer. Will insert new +subdirectories if necessary." + (interactive "p") + (if (< arg 0) (error "Can't go up a negative number of directories!")) + (or (zerop arg) + (let* ((dir (dired-current-directory)) + (n arg) + (up dir)) + (while (> n 0) + (setq up (file-name-directory (directory-file-name up)) + n (1- n))) + (if (and (< (length up) (length dired-directory)) + (dired-in-this-tree dired-directory up)) + (if (or (memq 'create-top-dir dired-no-confirm) + (y-or-n-p + (format "Insert new top dir %s and rename buffer? " + (dired-abbreviate-file-name up)))) + (let ((newname (let (buff) + (unwind-protect + (buffer-name + (setq buff + (create-file-buffer + (directory-file-name up)))) + (kill-buffer buff)))) + (buffer-read-only nil)) + (push-mark) + (widen) + (goto-char (point-min)) + (insert-before-markers "\n") + (forward-char -1) + (dired-insert-subdir-doupdate + up (dired-insert-subdir-doinsert up dired-internal-switches) + dired-internal-switches nil nil) + (dired-initial-position up) + (rename-buffer newname) + (dired-unadvertise default-directory) + (setq default-directory up + dired-directory up) + (dired-advertise))) + (dired-maybe-insert-subdir up))))) + +(defun dired-down-directory () + "Go down in the dired tree. +Moves to the first subdirectory of the current directory, which exists in +the dired buffer. Does not take a prefix argument." + ;; What would a prefix mean here? + (interactive) + (let ((dir (dired-current-directory)) ; has slash + (rest (reverse dired-subdir-alist)) + pos elt) + (while rest + (setq elt (car rest)) + (if (dired-in-this-tree (directory-file-name (car elt)) dir) + (setq rest nil + pos (dired-goto-subdir (car elt))) + (setq rest (cdr rest)))) + (prog1 + (if pos + (progn + (push-mark) + (goto-char pos)) + (error "At the bottom")) + (dired-update-mode-line t)))) + +(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) + "Go to next subdirectory, regardless of level." + ;; Use 0 arg to go to this directory's header line. + ;; NO-SKIP prevents moving to end of header line, returning whatever + ;; position was found in dired-subdir-alist. + (interactive "p") + (let ((this-dir (dired-current-directory)) + pos index) + ;; nth with negative arg does not return nil but the first element + (setq index (- (length dired-subdir-alist) + (length (memq (assoc this-dir dired-subdir-alist) + dired-subdir-alist)) + arg)) + (setq pos (if (>= index 0) + (dired-get-subdir-min (nth index dired-subdir-alist)))) + (if pos + (if no-skip + (goto-char pos) + (goto-char pos) + (skip-chars-forward "^\r\n") + (if (= (following-char) ?\r) + (skip-chars-backward "." (- (point) 3))) + (dired-update-mode-line t) + (point)) + (if no-error-if-not-found + nil ; return nil if not found + (error "%s directory" (if (> arg 0) "Last" "First")))))) + +(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) + "Go to previous subdirectory, regardless of level. +When called interactively and not on a subdir line, go to this subdir's line." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + ;; if on subdir start already, don't stay there! + (if (dired-get-subdir) 1 0)))) + (dired-next-subdir (- arg) no-error-if-not-found no-skip)) + +(defun dired-goto-subdir (dir) + "Goto end of header line of DIR in this dired buffer. +Return value of point on success, otherwise return nil. +The next char is either \\n, or \\r if DIR is hidden." + (interactive + (prog1 ; let push-mark display its message + (list + (let* ((table (mapcar + (function + (lambda (x) + (list (dired-abbreviate-file-name + (car x))))) + dired-subdir-alist)) + (stack (reverse (mapcar 'car table))) + (initial (car stack)) + (dired-goto-file-history (cdr stack))) + (expand-file-name + (dired-completing-read "Goto subdirectory " table nil t + initial 'dired-goto-file-history)))) + (push-mark))) + (setq dir (file-name-as-directory dir)) + (let ((elt (assoc dir dired-subdir-alist))) + (and elt + ;; need to make sure that we get where we're going. + ;; beware: narrowing might be in effect + (eq (goto-char (dired-get-subdir-min elt)) (point)) + (progn + ;; dired-subdir-hidden-p and dired-add-entry depend on point being + ;; at either \n or looking-at ...\r after this function succeeds. + (skip-chars-forward "^\r\n") + (if (= (preceding-char) ?.) + (skip-chars-backward "." (- (point) 3))) + (if (interactive-p) (dired-update-mode-line)) + (point))))) + +;;; Internals for motion commands + +(defun dired-update-mode-line (&optional force) + "Updates the mode line in dired according to the position of the point. +Normally this uses a cache of the boundaries of the current subdirectory, +but if the optional argument FORCE is non-nil, then modeline is always +updated and the cache is recomputed." + (if (or force + (>= (point) dired-curr-subdir-max) + (< (point) dired-curr-subdir-min)) + (let ((alist dired-subdir-alist) + min max) + (while (and alist (< (point) + (setq min (dired-get-subdir-min (car alist))))) + (setq alist (cdr alist) + max min)) + (setq dired-curr-subdir-max (or max (point-max-marker)) + dired-curr-subdir-min (or min (point-min-marker)) + dired-subdir-omit (nth 2 (car alist))) + (dired-sort-set-modeline (nth 3 (car alist)))))) + +(defun dired-manual-move-to-filename (&optional raise-error bol eol) + "In dired, move to first char of filename on this line. +Returns position (point) or nil if no filename on this line." + ;; This is the UNIX version. + ;; have to be careful that we don't move to omitted files + (let (case-fold-search) + + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (or bol (setq bol (progn (skip-chars-backward "^\r\n") (point)))) + + (if (or (memq ?l dired-internal-switches) + (memq ?g dired-internal-switches)) + (if (and + (> (- eol bol) 17) ; a valid file line must have at least + ; 17 chars. 2 leading, 10 perms, + ; separator, node #, separator, owner, + ; separator + (goto-char (+ bol 17)) + (re-search-forward dired-re-month-and-time eol t)) + (point) + (goto-char bol) + (if raise-error + (error "No file on this line") + nil)) + ;; else ls switches don't contain -l. + ;; Note that even if we make dired-move-to-filename and + ;; dired-move-to-end-of-filename (and thus dired-get-filename) + ;; work, all commands that gleaned information from the permission + ;; bits (like dired-mark-directories) will cease to work properly. + (if (= bol eol) + (if raise-error + (error "No file on this line") + nil) + ;; skip marker, if any + (goto-char bol) + (forward-char)) + ;; If we not going to use the l switch, and use nstd listings, + ;; then we must bomb on files starting with spaces. + (skip-chars-forward " \t") + (point)))) + +(defun dired-manual-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + ;; This is the UNIX version. + (let ((bof (point)) + file-type modes-start case-fold-search) + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (or (memq ?l dired-internal-switches) + (memq ?g dired-internal-switches)) + (if (save-excursion + (goto-char bol) + (re-search-forward + "[^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ][-+ 0-9+]" + bof t)) + (progn + (setq modes-start (match-beginning 0) + file-type (char-after modes-start)) + ;; Move point to end of name: + (if (eq file-type ?l) ; symlink + (progn + (if (search-forward " -> " eol t) + (goto-char (match-beginning 0)) + (goto-char eol)) + (and dired-ls-F-marks-symlinks + (eq (preceding-char) ?@) ; link really marked? + (memq ?F dired-internal-switches) + (forward-char -1)) + (point)) + ;; else not a symbolic link + (goto-char eol) + ;; ls -lF marks dirs, sockets and executables with exactly + ;; one trailing character. -F may not actually be honored, + ;; e.g. by an FTP ls in efs + (and + (memq ?F dired-internal-switches) + (let ((char (preceding-char))) + (or (and (eq char ?*) (or + (memq + (char-after (+ modes-start 3)) + '(?x ?s ?t)) + (memq + (char-after (+ modes-start 6)) + '(?x ?s ?t)) + (memq + (char-after (+ modes-start 9)) + '(?x ?s ?t)))) + (and (eq char ?=) (eq file-type ?s)))) + (forward-char -1)) + ;; Skip back over /'s unconditionally. It's not a valid + ;; file name character. + (skip-chars-backward "/") + (point))) + (and (null no-error) + (error "No file on this line"))) + + ;; A brief listing + (if (eq (point) eol) + (and (null no-error) + (error "No file on this line")) + (goto-char eol) + (if (and (memq (preceding-char) '(?@ ?* ?=)) + (memq ?F dired-internal-switches)) + ;; A guess, since without a long listing, we can't be sure. + (forward-char -1)) + (skip-chars-backward "/") + (point))))) + +(defun dired-goto-next-nontrivial-file () + ;; Position point on first nontrivial file after point. + ;; Does not move into the next sudir. + ;; If point is on a file line, moves to that file. + ;; This does not move to omitted files. + (skip-chars-backward "^\n\r") + (if (= (preceding-char) ?\r) + (forward-line 1)) + (let ((max (dired-subdir-max)) + file) + (while (and (or (not (setq file (dired-get-filename 'no-dir t))) + (string-match dired-trivial-filenames file)) + (< (point) max)) + (forward-line 1))) + (dired-move-to-filename)) + +(defun dired-goto-next-file () + ;; Doesn't move out of current subdir. Does go to omitted files. + ;; Returns the starting position of the file, or nil if none found. + (let ((max (dired-subdir-max)) + found) + (while (and (null (setq found (dired-move-to-filename))) (< (point) max)) + (skip-chars-forward "^\n\r") + (forward-char 1)) + found)) + +;; fluid vars used by dired-goto-file-completer +(defvar dired-completer-buffer nil) +(defvar dired-completer-switches nil) +(defvar dired-completer-cache nil) + +(defun dired-goto-file-completer (string pred action) + (save-excursion + (set-buffer dired-completer-buffer) + (let* ((saved-md (match-data)) + (file (file-name-nondirectory string)) + (dir (file-name-directory string)) + (xstring (expand-file-name string)) + (xdir (file-name-directory xstring)) + (exact (dired-goto-file xstring))) + (unwind-protect + (if (dired-goto-subdir xdir) + (let ((table (cdr (assoc xdir dired-completer-cache))) + fn result max) + (or table + (progn + (setq table (make-vector 37 0)) + (mapcar (function + (lambda (ent) + (setq ent (directory-file-name + (car ent))) + (if (string-equal + (file-name-directory ent) xdir) + (intern + (concat + (file-name-nondirectory ent) "/") + table)))) + dired-subdir-alist) + (or (looking-at "\\.\\.\\.\n\r") + (progn + (setq max (dired-subdir-max)) + (while (and + (< (point) max) + (not + (setq fn + (dired-get-filename 'no-dir t)))) + (forward-line 1)) + (if fn + (progn + (or (intern-soft (concat fn "/") table) + (intern fn table)) + (forward-line 1) + (while (setq fn + (dired-get-filename 'no-dir t)) + (or (intern-soft (concat fn "/") table) + (intern fn table)) + (forward-line 1)))))) + (setq dired-completer-cache (cons + (cons xdir table) + dired-completer-cache)))) + (cond + ((null action) + (setq result (try-completion file table)) + (if exact + (if (stringp result) + string + t) + (if (stringp result) + (concat dir result) + result))) + ((eq action t) + (setq result (all-completions file table)) + (if exact (cons "." result) result)) + ((eq 'lambda action) + (and (or exact (intern-soft file table))))))) + (store-match-data saved-md))))) + +(defun dired-really-goto-file (file) + ;; Goes to a file, even if it needs to insert it parent directory. + (or (dired-goto-file file) + (progn ; refresh and try again + (dired-insert-subdir (file-name-directory file)) + (dired-goto-file file)))) + +(defun dired-between-files () + ;; Point must be at beginning of line + (save-excursion (not (dired-move-to-filename nil (point))))) + +(defun dired-repeat-over-lines (arg function) + ;; This version skips non-file lines. + ;; Skips file lines hidden with selective display. + ;; BACKWARDS means move backwards after each action. This is not the same + ;; as a negative arg, as that skips the current line. + (beginning-of-line) + (let* ((advance (cond ((> arg 0) 1) ((< arg 0) -1) (t nil))) + (check-fun (if (eq advance 1) 'eobp 'bobp)) + (n (if (< arg 0) (- arg) arg)) + (wall (funcall check-fun)) + (done wall)) + (while (not done) + (if advance + (progn + (while (not (or (save-excursion (dired-move-to-filename)) + (setq wall (funcall check-fun)))) + (forward-line advance)) + (or wall + (progn + (save-excursion (funcall function)) + (forward-line advance) + (while (not (or (save-excursion (dired-move-to-filename)) + (setq wall (funcall check-fun)))) + (forward-line advance)) + (setq done (or (zerop (setq n (1- n))) wall))))) + (if (save-excursion (dired-move-to-filename)) + (save-excursion (funcall function))) + (setq done t)))) + (dired-move-to-filename) + ;; Note that if possible the point has now been moved to the beginning of + ;; the file name. + (dired-update-mode-line)) + + +;;;; ---------------------------------------------------------------- +;;;; Miscellaneous dired commands +;;;; ---------------------------------------------------------------- + +(defun dired-quit () + "Bury the current dired buffer." + (interactive) + (bury-buffer)) + +(defun dired-undo () + "Undo in a dired buffer. +This doesn't recover lost files, it is just normal undo with temporarily +writeable buffer. You can use it to recover marks, killed lines or subdirs." + (interactive) + (let ((lines (count-lines (point-min) (point-max))) + buffer-read-only) + (undo) + ;; reset dired-subdir-alist, if a dir may have been affected + ;; Is there a better way to guess this? + (setq lines (- (count-lines (point-min) (point-max)) lines)) + (if (or (>= lines 2) (<= lines -2)) + (dired-build-subdir-alist))) + (dired-update-mode-line-modified t) + (dired-update-mode-line t)) + + +;;;; -------------------------------------------------------- +;;;; Immediate actions on files: visiting, viewing, etc. +;;;; -------------------------------------------------------- + +(defun dired-find-file () + "In dired, visit the file or directory named on this line." + (interactive) + (find-file (dired-get-filename))) + +(defun dired-view-file () + "In dired, examine a file in view mode, returning to dired when done. +When file is a directory, show it in this buffer if it is inserted; +otherwise, display it in another buffer." + (interactive) + (let ((file (dired-get-filename))) + (if (file-directory-p file) + (or (dired-goto-subdir file) + (dired file)) + (view-file file)))) + +(defun dired-find-file-other-window (&optional display) + "In dired, visit this file or directory in another window. +With a prefix, the file is displayed, but the window is not selected." + (interactive "P") + (if display + (dired-display-file) + (find-file-other-window (dired-get-filename)))) + +;; Only for Emacs 19 +(defun dired-find-file-other-frame () + "In dired, visit this file or directory in another frame." + (interactive) + (find-file-other-frame (dired-get-filename))) + +(defun dired-display-file () + "In dired, displays this file or directory in the other window." + (interactive) + (display-buffer (find-file-noselect (dired-get-filename)))) + +;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). +(defun dired-do-find-file (&optional arg) + "Visit all marked files at once, and display them simultaneously. +See also function `simultaneous-find-file'. +If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. +If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." + (interactive "P") + (dired-simultaneous-find-file (dired-get-marked-files nil arg))) + +(defun dired-simultaneous-find-file (file-list) + "Visit all files in FILE-LIST and display them simultaneously. + +The current window is split across all files in FILE-LIST, as evenly +as possible. Remaining lines go to the bottommost window. + +The number of files that can be displayed this way is restricted by +the height of the current window and the variable `window-min-height'." + ;; It is usually too clumsy to specify FILE-LIST interactively + ;; unless via dired (dired-do-find-file). + (let ((size (/ (window-height) (length file-list)))) + (or (<= window-min-height size) + (error "Too many files to visit simultaneously")) + (find-file (car file-list)) + (setq file-list (cdr file-list)) + (while file-list + ;; Split off vertically a window of the desired size + ;; The upper window will have SIZE lines. We select the lower + ;; (larger) window because we want to split that again. + (select-window (split-window nil size)) + (find-file (car file-list)) + (setq file-list (cdr file-list))))) + +(defun dired-create-directory (directory) + "Create a directory called DIRECTORY." + (interactive + (list (read-file-name "Create directory: " + (dired-abbreviate-file-name + (dired-current-directory))))) + (let ((expanded (expand-file-name directory))) + (make-directory expanded) + ;; Because this function is meant to be called interactively, it moves + ;; the point. + (dired-goto-file expanded))) + +(defun dired-recover-file () + "Recovers file from its autosave file. +If the file is an autosave file, then recovers its associated file instead." + (interactive) + (let* ((file (dired-get-filename)) + (name (file-name-nondirectory file)) + (asp (auto-save-file-name-p name)) + (orig (and + asp + (if (fboundp 'auto-save-original-name) + (auto-save-original-name file) + (error + "Need auto-save package to compute original file name.")))) + (buff (if asp + (and orig (get-file-buffer orig)) + (get-file-buffer file)))) + (and + buff + (buffer-modified-p buff) + (or + (yes-or-no-p + (format + "Recover file will erase the modified buffer %s. Do it? " + (buffer-name buff))) + (error "Recover file aborted."))) + (if asp + (if orig + (recover-file orig) + (find-file file)) + (recover-file file)))) + + +;;;; -------------------------------------------------------------------- +;;;; Functions for extracting and manipulating file names +;;;; -------------------------------------------------------------------- + +(defun dired-make-filename-string (filename &optional reverse) + ;; Translates the way that a file name appears in a buffer, to + ;; how it is used in a path name. This is useful for non-unix + ;; support in efs. + filename) + +(defun dired-get-filename (&optional localp no-error-if-not-filep) + "In dired, return name of file mentioned on this line. +Value returned normally includes the directory name. +Optional arg LOCALP with value `no-dir' means don't include directory + name in result. A value of t means use path name relative to + `default-directory', which still may contain slashes if in a subdirectory. +Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on + this line, otherwise an error occurs." + + ;; Compute bol & eol once, rather than twice inside move-to-filename + ;; and move-to-end-of-filename + (let ((eol (save-excursion (skip-chars-forward "^\n\r") (point))) + (bol (save-excursion (skip-chars-backward "^\r\n") (point))) + case-fold-search file p1 p2) + (save-excursion + (and + (setq p1 (dired-move-to-filename (not no-error-if-not-filep) bol eol)) + (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep bol eol)) + (setq file (buffer-substring p1 p2)) + ;; Check if ls quoted the names, and unquote them. + ;; Using read to unquote is much faster than substituting + ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. + (cond ((memq ?b dired-internal-switches) ; System V ls + ;; This case is about 20% slower than without -b. + (setq file + (read + (concat "\"" + ;; some ls -b don't escape quotes, argh! + ;; This is not needed for GNU ls, though. + (or (dired-string-replace-match + "\\([^\\]\\)\"" file "\\1\\\\\"") + file) + "\"")))) + ;; If you do this, update dired-compatible-switches-p + ;; ((memq ?Q dired-internal-switches) ; GNU ls + ;; (setq file (read file))) + ))) + (and file + (if (eq localp 'no-dir) + (dired-make-filename-string file) + (concat (dired-current-directory localp) + (dired-make-filename-string file)))))) + +(defun dired-make-relative (file &optional dir no-error) + ;; Convert FILE (an *absolute* pathname) to a pathname relative to DIR. + ;; FILE must be absolute, or this function will return nonsense. + ;; If FILE is not in a subdir of DIR, an error is signalled, + ;; unless NO-ERROR is t. Then, ".."'s are inserted to give + ;; a relative representation of FILE wrto DIR + ;; eg. FILE = /vol/tex/bin/foo DIR = /vol/local/bin/ + ;; results in ../../tex/bin/foo + ;; DIR must be expanded. + ;; DIR defaults to default-directory. + ;; DIR must be file-name-as-directory, as with all directory args in + ;; elisp code. + (or dir (setq dir (expand-file-name default-directory))) + (let ((flen (length file)) + (dlen (length dir))) + (if (and (> flen dlen) + (string-equal (substring file 0 dlen) dir)) + (substring file dlen) + ;; Need to insert ..'s + (or no-error (error "%s: not in directory tree growing at %s" file dir)) + (if (string-equal file dir) + "./" + (let ((index 1) + (count 0)) + (while (and (string-match "/" dir index) + (<= (match-end 0) flen) + (string-equal (substring file index (match-end 0)) + (substring dir index (match-end 0)))) + (setq index (match-end 0))) + (setq file (substring file index)) + (if (and (/= flen index) + (not (string-match "/" file)) + (< flen dlen) + (string-equal file (substring dir index flen)) + (= (aref dir flen) ?/)) + (setq file "." + count -1)) + ;; count how many slashes remain in dir. + (while (string-match "/" dir index) + (setq index (match-end 0) + count (1+ count))) + (apply 'concat (nconc (make-list count "../") (list file)))))))) + +;;; Functions for manipulating file names. +;; +;; Used by file tranformers. +;; Define here rather than in dired-shell.el, as it wouldn't be +;; unreasonable to use these elsewhere. + +(defun dired-file-name-base (fn) + "Returns the base name of FN. +This is the file without directory part, and extension. See the variable +`dired-filename-re-ext'." + (setq fn (file-name-nondirectory fn)) + (if (string-match dired-filename-re-ext fn 1) + (substring fn 0 (match-beginning 0)) + fn)) + +(defun dired-file-name-extension (fn) + "Returns the extension for file name FN. +See the variable dired-filename-re-ext'." + (setq fn (file-name-nondirectory fn)) + (if (string-match dired-filename-re-ext fn 1) + (substring fn (match-beginning 0)) + "")) + +(defun dired-file-name-sans-rcs-extension (fn) + "Returns the file name FN without its RCS extension \",v\"." + (setq fn (file-name-nondirectory fn)) + (if (string-match ",v$" fn 1) + (substring fn 0 (match-beginning 0)) + fn)) + +(defun dired-file-name-sans-compress-extension (fn) + "Returns the file name FN without the extension from compress or gzip." + (setq fn (file-name-nondirectory fn)) + (if (string-match "\\.\\([zZ]\\|gz\\)$" fn 1) + (substring fn (match-beginning 0)) + fn)) + + +;;;; --------------------------------------------------------------------- +;;;; Working with directory trees. +;;;; --------------------------------------------------------------------- +;;; +;;; This where code for the dired-subdir-alist is. + +;;; Utility functions for dired-subdir-alist + +(defun dired-normalize-subdir (dir) + ;; Prepend default-directory to DIR if relative path name. + ;; dired-get-filename must be able to make a valid filename from a + ;; file and its directory DIR. + ;; Fully expand everything. + (file-name-as-directory + (if (file-name-absolute-p dir) + (expand-file-name dir) + (expand-file-name dir (expand-file-name default-directory))))) + +(defun dired-get-subdir () + ;;"Return the subdir name on this line, or nil if not on a headerline." + ;; Look up in the alist whether this is a headerline. + (save-excursion + (let ((cur-dir (dired-current-directory))) + (beginning-of-line) ; alist stores b-o-l positions + (and (zerop (- (point) + (dired-get-subdir-min (assoc cur-dir + dired-subdir-alist)))) + cur-dir)))) + +(defun dired-get-subdir-max (elt) + ;; returns subdir max. + (let ((pos (- (length dired-subdir-alist) + (length (member elt dired-subdir-alist))))) + (if (zerop pos) + (point-max) + (1- (dired-get-subdir-min (nth (1- pos) dired-subdir-alist)))))) + +(defun dired-clear-alist () + ;; Set all markers in dired-subdir-alist to nil. Set the alist to nil too. + (while dired-subdir-alist + (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) + (setq dired-subdir-alist (cdr dired-subdir-alist)))) + +(defun dired-unsubdir (dir) + ;; Remove DIR from the alist + (setq dired-subdir-alist + (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) + +(defun dired-simple-subdir-alist () + ;; Build and return `dired-subdir-alist' assuming just the top level + ;; directory to be inserted. Don't parse the buffer. + (setq dired-subdir-alist + (list (list (expand-file-name default-directory) + (point-min-marker) dired-omit-files + dired-internal-switches nil))) + (if dired-verify-modtimes + (dired-set-file-modtime (expand-file-name default-directory) + dired-subdir-alist))) + +(defun dired-build-subdir-alist () + "Build `dired-subdir-alist' by parsing the buffer and return its new value." + (interactive) + (let ((o-alist dired-subdir-alist) + (count 0) + subdir) + (dired-clear-alist) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward dired-subdir-regexp nil t) + (setq count (1+ count)) + (apply 'dired-alist-add-1 + (setq subdir (buffer-substring (match-beginning 2) + (match-end 2))) + ;; Put subdir boundary between lines. + (set-marker (make-marker) (match-end 1)) + (let ((elt (assoc subdir o-alist))) + (if elt + (list (nth 2 elt) (nth 3 elt)) + (list dired-omit-files dired-internal-switches))))) + (if (interactive-p) + (message "%d director%s." count (if (= 1 count) "y" "ies"))) + ;; We don't need to sort it because it is in buffer order per + ;; constructionem. Return new alist: + ;; pointers for current-subdir may be stale + dired-subdir-alist))) + +(defun dired-alist-add (dir new-marker &optional omit switches) + ;; Add new DIR at NEW-MARKER. Sort alist. + (dired-alist-add-1 dir new-marker omit switches) + (dired-alist-sort)) + +(defun dired-alist-add-1 (dir new-marker &optional omit switches) + ;; Add new DIR at NEW-MARKER. Don't sort. + (let ((dir (dired-normalize-subdir dir))) + (setq dired-subdir-alist + (cons (list dir new-marker omit switches nil) dired-subdir-alist)) + (if dired-verify-modtimes + (dired-set-file-modtime dir dired-subdir-alist)))) + +(defun dired-alist-sort () + ;; Keep the alist sorted on buffer position. + (setq dired-subdir-alist + (sort dired-subdir-alist + (function (lambda (elt1 elt2) + (> (dired-get-subdir-min elt1) + (dired-get-subdir-min elt2))))))) + +;;; Utilities for working with subdirs in the dired buffer + +;; This function is the heart of tree dired. +;; It is called for each retrieved filename. +;; It could stand to be faster, though it's mostly function call +;; overhead. Avoiding to funcall seems to save about 10% in +;; dired-get-filename. Make it a defsubst? +(defun dired-current-directory (&optional localp) + "Return the name of the subdirectory to which this line belongs. +This returns a string with trailing slash, like `default-directory'. +Optional argument means return a file name relative to `default-directory'. +In this it returns \"\" for the top directory." + (let* ((here (point)) + (dir (catch 'done + (mapcar (function + (lambda (x) + (if (<= (dired-get-subdir-min x) here) + (throw 'done (car x))))) + dired-subdir-alist)))) + (if (listp dir) (error "dired-subdir-alist seems to be mangled")) + (if localp + (let ((def-dir (expand-file-name default-directory))) + (if (string-equal dir def-dir) + "" + (dired-make-relative dir def-dir))) + dir))) + +;; Subdirs start at the beginning of their header lines and end just +;; before the beginning of the next header line (or end of buffer). + +(defun dired-subdir-min () + ;; Returns the minimum position of the current subdir + (save-excursion + (if (not (dired-prev-subdir 0 t t)) + (error "Not in a subdir!") + (point)))) + +(defun dired-subdir-max () + ;; Returns the maximum position of the current subdir + (save-excursion + (if (dired-next-subdir 1 t t) + (1- (point)) ; Do not include separating empty line. + (point-max)))) + + +;;;; -------------------------------------------------------- +;;;; Deleting files +;;;; -------------------------------------------------------- + +(defun dired-flag-file-deletion (arg) + "In dired, flag the current line's file for deletion. +With prefix arg, repeat over several lines. + +If on a subdir headerline, mark all its files except `.' and `..'." + (interactive "p") + (dired-mark arg dired-del-marker)) + +(defun dired-flag-file-deletion-backup (arg) + "Flag current file for deletion, and move to previous line. +With a prefix ARG, repeats this ARG times." + (interactive "p") + ;; Use dired-mark-file and not dired-mark, as this function + ;; should do nothing special on subdir headers. + (dired-mark-file (- arg) dired-del-marker)) + +(defun dired-flag-subdir-files () + "Flag all the files in the current subdirectory for deletion." + (interactive) + (dired-mark-subdir-files dired-del-marker)) + +(defun dired-unflag (arg) + "In dired, remove a deletion flag from the current line's file. +Optional prefix ARG says how many lines to unflag." + (interactive "p") + (let (buffer-read-only) + (dired-repeat-over-lines + arg + (function + (lambda () + (if (char-equal (following-char) dired-del-marker) + (progn + (setq dired-del-flags-number (max (1- dired-del-flags-number) 0)) + (dired-substitute-marker (point) dired-del-marker ?\ ))))))) + (dired-update-mode-line-modified)) + +(defun dired-backup-unflag (arg) + "In dired, move up lines and remove deletion flag there. +Optional prefix ARG says how many lines to unflag; default is one line." + (interactive "p") + (dired-unflag (- arg))) + +(defun dired-update-marker-counters (char &optional remove) + (or (memq char '(?\ ?\n ?\r)) + (let ((counter (cond + ((char-equal char dired-del-marker) + 'dired-del-flags-number) + ((char-equal char dired-marker-char) + 'dired-marks-number) + ('dired-other-marks-number)))) + (if remove + (set counter (max (1- (symbol-value counter)) 0)) + (set counter (1+ (symbol-value counter))))))) + +(defun dired-update-mode-line-modified (&optional check) + ;; Updates the value of mode-line-modified in dired. + ;; Currently assumes that it's of the form "-%%-", where % sometimes + ;; gets replaced by %. Should allow some sort of config flag. + ;; SET is t to set to -DD-, nil to set to -%%-, and 'check means + ;; examine the buffer to find out. + (if check + (save-excursion + (let (char) + (goto-char (point-min)) + (setq dired-del-flags-number 0 + dired-marks-number 0 + dired-other-marks-number 0) + (while (not (eobp)) + (setq char (following-char)) + (cond + ((char-equal char dired-del-marker) + (setq dired-del-flags-number (1+ dired-del-flags-number))) + ((char-equal char dired-marker-char) + (setq dired-marks-number (1+ dired-marks-number))) + ((memq char '(?\ ?\n ?\r)) + nil) + ((setq dired-other-marks-number (1+ dired-other-marks-number)))) + (forward-line 1))))) + (setq mode-line-modified + (format dired-mode-line-modified + (if (zerop dired-del-flags-number) + "--" + (format "%d%c" dired-del-flags-number dired-del-marker)) + (if (zerop dired-marks-number) + "--" + (format "%d%c" dired-marks-number dired-marker-char)) + (if (zerop dired-other-marks-number) + "-" + (int-to-string dired-other-marks-number)))) + (set-buffer-modified-p (buffer-modified-p))) + +(defun dired-do-deletions (&optional nomessage) + (dired-expunge-deletions)) + +(defun dired-expunge-deletions () + "In dired, delete the files flagged for deletion." + (interactive) + (let ((files (let ((dired-marker-char dired-del-marker)) + (dired-map-over-marks (cons (dired-get-filename) (point)) + t)))) + (if files + (progn + (dired-internal-do-deletions files nil dired-del-marker) + ;; In case the point gets left somewhere strange -- hope that + ;; this doesn't cause asynch troubles later. + (beginning-of-line) + (dired-goto-next-nontrivial-file) + (dired-update-mode-line-modified t)) ; play safe, it's cheap + (message "(No deletions requested)")))) + +(defun dired-do-delete (&optional arg) + "Delete all marked (or next ARG) files." + ;; This is more consistent with the file marking feature than + ;; dired-expunge-deletions. + (interactive "P") + (dired-internal-do-deletions + ;; this may move point if ARG is an integer + (dired-map-over-marks (cons (dired-get-filename) (point)) + arg) + arg) + (beginning-of-line) + (dired-goto-next-nontrivial-file)) + +(defun dired-internal-do-deletions (l arg &optional marker-char) + ;; L is an alist of files to delete, with their buffer positions. + ;; ARG is the prefix arg. + ;; Filenames are absolute (VMS needs this for logical search paths). + ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. + ;; That way as changes are made in the buffer they do not shift the + ;; lines still to be changed, so the (point) values in L stay valid. + ;; Also, for subdirs in natural order, a subdir's files are deleted + ;; before the subdir itself - the other way around would not work. + (save-excursion + (let ((files (mapcar (function car) l)) + (count (length l)) + (succ 0) + (cdir (dired-current-directory)) + failures) + ;; canonicalize file list for pop up + (setq files (nreverse (mapcar (function + (lambda (fn) + (dired-make-relative fn cdir t))) + files))) + (if (or (memq 'delete dired-no-confirm) + (dired-mark-pop-up + " *Files Flagged for Deletion*" 'delete files + dired-deletion-confirmer + (format "Delete %s " + (dired-mark-prompt arg files marker-char)))) + (save-excursion + ;; files better be in reverse order for this loop! + (while l + (goto-char (cdr (car l))) + (condition-case err + (let ((fn (car (car l)))) + ;; This test is equivalent to + ;; (and (file-directory-p fn) + ;; (not (file-symlink-p fn))) + ;; but more efficient + (if (if (eq t (car (file-attributes fn))) + (if (<= (length (directory-files fn)) 2) + (progn (delete-directory fn) t) + (and (or + (memq 'recursive-delete dired-no-confirm) + (funcall + dired-deletion-confirmer + (format "\ +Recursively delete directory and files within %s? " + (dired-make-relative fn)))) + (progn + (dired-recursive-delete-directory fn) + t))) + (progn (delete-file fn) t)) + (progn + (setq succ (1+ succ)) + (message "%s of %s deletions" succ count) + (dired-clean-up-after-deletion fn)))) + (error;; catch errors from failed deletions + (dired-log (buffer-name (current-buffer)) "%s\n" err) + (setq failures (cons (car (car l)) failures)))) + (setq l (cdr l))))) + (if failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "%d of %d deletion%s failed:" (length failures) count + (dired-plural-s count)) + failures) + (if (zerop succ) + (message "(No deletions performed)") + (message "%d deletion%s done" succ (dired-plural-s succ))))))) + +(defun dired-recursive-delete-directory (fn) + ;; Recursively deletes directory FN, and all of its contents. + (let* ((fn (expand-file-name fn)) + (handler (find-file-name-handler + fn 'dired-recursive-delete-directory))) + (if handler + (funcall handler 'dired-recursive-delete-directory fn) + (progn + (or (file-exists-p fn) + (signal + 'file-error + (list "Removing old file name" "no such directory" fn))) + ;; Which is better, -r or -R? + (call-process "rm" nil nil nil "-r" (directory-file-name fn)) + (and (file-exists-p fn) + (error "Failed to recusively delete %s" fn)))))) + +(defun dired-clean-up-after-deletion (fn) + ;; Offer to kill buffer of deleted file FN. + (let ((buf (get-file-buffer fn))) + (and buf + (or (memq 'kill-file-buffer dired-no-confirm) + (funcall (function yes-or-no-p) + (format "Kill buffer of %s, too? " + (file-name-nondirectory fn)))) + (save-excursion ; you never know where kill-buffer leaves you + (kill-buffer buf))))) + +;;; Cleaning a directory -- flagging backups for deletion + +(defun dired-clean-directory (keep &optional marker msg) + "Flag numerical backups for deletion. +Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. +Positive prefix arg KEEP overrides `dired-kept-versions'; +Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. + +To clear the flags on these files, you can use \\[dired-flag-backup-files] +with a prefix argument." + (interactive "P") + (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) + (let* ((early-retention (if (< keep 0) (- keep) kept-old-versions)) + (late-retention (if (<= keep 0) dired-kept-versions keep)) + (msg (or msg + (format + "Cleaning numerical backups (keeping %d late, %d old)" + late-retention early-retention))) + (trample-marker (or marker dired-del-marker)) + (file-version-assoc-list)) + (message "%s..." msg) + ;; Do this after messaging, as it may take a while. + (setq file-version-assoc-list (dired-collect-file-versions)) + ;; Sort each VERSION-NUMBER-LIST, + ;; and remove the versions to be deleted. + (let ((fval file-version-assoc-list)) + (while fval + (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) + (v-count (length sorted-v-list))) + (if (> v-count (+ early-retention late-retention)) + (rplacd (nthcdr early-retention sorted-v-list) + (nthcdr (- v-count late-retention) + sorted-v-list))) + (rplacd (car fval) + (cdr sorted-v-list))) + (setq fval (cdr fval)))) + ;; Look at each file. If it is a numeric backup file, + ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. + (dired-map-dired-file-lines (function + (lambda (fn) + (dired-trample-file-versions + fn file-version-assoc-list + trample-marker)))) + (message "%s...done" msg))) + +(defun dired-collect-file-versions () + ;; If it looks like a file has versions, return a list of the versions. + ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) + (let (result) + (dired-map-dired-file-lines + (function + (lambda (fn) + (let* ((base-versions + (concat (file-name-nondirectory fn) ".~")) + (bv-length (length base-versions)) + (possibilities (file-name-all-completions + base-versions + (file-name-directory fn)))) + (if possibilities + (setq result (cons (cons fn + (mapcar 'backup-extract-version + possibilities)) result))))))) + result)) + +(defun dired-trample-file-versions (fn alist marker) + ;; ALIST is an alist of filenames and versions used to determine + ;; if each file should be flagged for deletion. + ;; This version using file-name-sans-versions is probably a lot slower + ;; than Sebastian's original, but it is more easily adaptable to non-unix. + (let ((base (file-name-sans-versions fn)) + base-version-list bv-length) + (and (not (string-equal base fn)) + (setq base-version-list (assoc base alist)) + (setq bv-length (string-match "[0-9]" fn (length base))) + (not (memq (backup-extract-version fn) base-version-list)) + (progn (skip-chars-backward "^\n\r") + (bolp)) ; make sure the preceding char isn't \r. + (dired-substitute-marker (point) (following-char) marker)))) + +(defun dired-map-dired-file-lines (fun) + ;; Perform FUN with point at the end of each non-directory line. + ;; FUN takes one argument, the filename (complete pathname). + (dired-check-ls-l) + (save-excursion + (let (file buffer-read-only) + (goto-char (point-min)) + (while (not (eobp)) + (save-excursion + (and (not (and dired-re-dir (looking-at dired-re-dir))) + (not (memq (following-char) '(?\n ?\n))) + (setq file (dired-get-filename nil t)) ; nil on non-file + (progn (skip-chars-forward "^\n\r") + (funcall fun file)))) + (forward-line 1))))) ; this guarantees that we don't + ; operate on omitted files. + + +;;;; ----------------------------------------------------------- +;;;; Confirmations and prompting the user. +;;;; ----------------------------------------------------------- + +(defun dired-plural-s (count) + (if (= 1 count) "" "s")) + +(defun dired-mark-prompt (arg files &optional marker-char) + ;; Return a string for use in a prompt, either the current file + ;; name, or the marker and a count of marked files. + (let ((count (length files))) + (if (= count 1) + (car files) + ;; more than 1 file: + (if (integerp arg) + (cond ((zerop arg) "[no files]") + ((> arg 0) "[following]") + ((< arg 0) "[preceding]")) + (char-to-string (or marker-char dired-marker-char)))))) + +(defun dired-pop-to-buffer (buf) + ;; Pop up buffer BUF. + ;; Make its window fit its contents. + (let ((window (selected-window)) + target-lines w2) + (cond ;; if split-window-threshold is enabled, use the largest window + ((and (> (window-height (setq w2 (get-largest-window))) + split-height-threshold) + (= (frame-width) (window-width w2))) + (setq window w2)) + ;; if the least-recently-used window is big enough, use it + ((and (> (window-height (setq w2 (get-lru-window))) + (* 2 window-min-height)) + (= (frame-width) (window-width w2))) + (setq window w2))) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (skip-chars-backward "\n\r\t ") + (setq target-lines (count-lines (point-min) (point))) + ;; Don't forget to count the last line. + (if (not (bolp)) + (setq target-lines (1+ target-lines)))) + (if (<= (window-height window) (* 2 window-min-height)) + ;; At this point, every window on the frame is too small to split. + (setq w2 (display-buffer buf)) + (setq w2 (split-window + window + (max window-min-height + (- (window-height window) + (1+ (max window-min-height target-lines))))))) + (set-window-buffer w2 buf) + (if (< (1- (window-height w2)) target-lines) + (progn + (select-window w2) + (enlarge-window (- target-lines (1- (window-height w2)))))) + (set-window-start w2 1))) + +(defun dired-mark-pop-up (bufname op-symbol files function &rest args) + ;; Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. + ;; Return FUNCTION's result on ARGS after popping up a window (in a buffer + ;; named BUFNAME, nil gives \" *Marked Files*\") showing the marked + ;; files. Uses function `dired-pop-to-buffer' to do that. + ;; FUNCTION should not manipulate files. + ;; It should only read input (an argument or confirmation). + ;; The window is not shown if there is just one file or + ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. + ;; FILES is the list of marked files. + (if (memq op-symbol dired-no-confirm) + (apply function args) + (or bufname (setq bufname " *Marked Files*")) + (if (<= (length files) 1) + (apply function args) + (save-excursion + (let ((standard-output (set-buffer (get-buffer-create bufname)))) + (erase-buffer) + (dired-format-columns-of-files files) + (dired-remove-text-properties (point-min) (point-max)) + (setq mode-line-format (format " %s [%d files]" + bufname (length files))))) + (save-window-excursion + (dired-pop-to-buffer bufname) + (apply function args))))) + +(defun dired-column-widths (columns list &optional across) + ;; Returns the column widths for breaking LIST into + ;; COLUMNS number of columns. + (cond + ((null list) + nil) + ((= columns 1) + (list (apply 'max (mapcar 'length list)))) + ((let* ((len (length list)) + (col-length (/ len columns)) + (remainder (% len columns)) + (i 0) + (j 0) + (max-width 0) + widths padding) + (if (zerop remainder) + (setq padding 0) + (setq col-length (1+ col-length) + padding (- columns remainder))) + (setq list (nconc (copy-sequence list) (make-list padding nil))) + (setcdr (nthcdr (1- (+ len padding)) list) list) + (while (< i columns) + (while (< j col-length) + (setq max-width (max max-width (length (car list))) + list (if across (nthcdr columns list) (cdr list)) + j (1+ j))) + (setq widths (cons (+ max-width 2) widths) + max-width 0 + j 0 + i (1+ i)) + (if across (setq list (cdr list)))) + (setcar widths (- (car widths) 2)) + (nreverse widths))))) + +(defun dired-calculate-columns (list &optional across) + ;; Returns a list of integers which are the column widths that best pack + ;; LIST, a list of strings, onto the screen. + (and list + (let* ((width (1- (window-width))) + (columns (max 1 (/ width + (+ 2 (apply 'max (mapcar 'length list)))))) + col-list last-col-list) + (while (<= (apply '+ (setq col-list + (dired-column-widths columns list across))) + width) + (setq columns (1+ columns) + last-col-list col-list)) + (or last-col-list col-list)))) + +(defun dired-format-columns-of-files (files &optional across) + ;; Returns the number of lines used. + ;; If ACROSS is non-nil, sorts across rather than down the buffer, like + ;; ls -x + (and files + (let* ((columns (dired-calculate-columns files across)) + (ncols (length columns)) + (ncols1 (1- ncols)) + (nfiles (length files)) + (nrows (+ (/ nfiles ncols) + (if (zerop (% nfiles ncols)) 0 1))) + (space-left (- (window-width) (apply '+ columns) 1)) + (i 0) + (j 0) + file padding stretch float-stretch) + (if (zerop ncols1) + (setq stretch 0 + float-stretch 0) + (setq stretch (/ space-left ncols1) + float-stretch (% space-left ncols1))) + (setq files (nconc (copy-sequence files) ; fill up with empty fns + (make-list (- (* ncols nrows) nfiles) ""))) + (setcdr (nthcdr (1- (length files)) files) files) ; make circular + (while (< j nrows) + (while (< i ncols) + (princ (setq file (car files))) + (setq padding (- (nth i columns) (length file))) + (or (= i ncols1) + (progn + (setq padding (+ padding stretch)) + (if (< i float-stretch) (setq padding (1+ padding))))) + (princ (make-string padding ?\ )) + (setq files (if across (cdr files) (nthcdr nrows files)) + i (1+ i))) + (princ "\n") + (setq i 0 + j (1+ j)) + (or across (setq files (cdr files)))) + nrows))) + +(defun dired-query (qs-var qs-prompt &rest qs-args) + ;; Query user and return nil or t. + ;; Store answer in symbol VAR (which must initially be bound to nil). + ;; Format PROMPT with ARGS. + ;; Binding variable help-form will help the user who types C-h. + (let* ((char (symbol-value qs-var)) + (action (cdr (assoc char dired-query-alist)))) + (cond ((eq 'yes action) + t) ; accept, and don't ask again + ((eq 'no action) + nil) ; skip, and don't ask again + (t;; no lasting effects from last time we asked - ask now + (let ((qprompt (concat qs-prompt + (if help-form + (format " [yn!q or %s] " + (key-description + (char-to-string help-char))) + " [ynq or !] "))) + (dired-in-query t) + elt) + ;; Actually it looks nicer without cursor-in-echo-area - you can + ;; look at the dired buffer instead of at the prompt to decide. + (apply 'message qprompt qs-args) + (setq char (set qs-var (read-char))) + (while (not (setq elt (assoc char dired-query-alist))) + (message "Invalid char - type %c for help." help-char) + (ding) + (sit-for 1) + (apply 'message qprompt qs-args) + (setq char (set qs-var (read-char)))) + (memq (cdr elt) '(t y yes))))))) + +(defun dired-mark-confirm (op-symbol operation arg) + ;; Request confirmation from the user that the operation described + ;; by OP-SYMBOL is to be performed on the marked files. + ;; Confirmation consists in a y-or-n question with a file list + ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. + ;; OPERATION is a string describing the operation. Used for prompting + ;; the user. + ;; The files used are determined by ARG (like in dired-get-marked-files). + (or (memq op-symbol dired-no-confirm) + (let ((files (dired-get-marked-files t arg))) + (dired-mark-pop-up nil op-symbol files (function y-or-n-p) + (concat operation " " + (dired-mark-prompt arg files) "? "))))) + +(defun dired-mark-read-file-name (prompt dir op-symbol arg files) + (dired-mark-pop-up + nil op-symbol files + (function read-file-name) + (format prompt (dired-mark-prompt arg files)) dir)) + +(defun dired-mark-read-string (prompt initial op-symbol arg files + &optional history-sym) + ;; Reading arguments with history. + ;; Read arguments for a mark command of type OP-SYMBOL, + ;; perhaps popping up the list of marked files. + ;; ARG is the prefix arg and indicates whether the files came from + ;; marks (ARG=nil) or a repeat factor (integerp ARG). + ;; If the current file was used, the list has but one element and ARG + ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). + ;; PROMPT for a string, with INITIAL input. + (dired-mark-pop-up + nil op-symbol files + (function + (lambda (prompt initial) + (let ((hist (or history-sym + (cdr (assq op-symbol dired-op-history-alist)) + 'dired-history))) + (dired-read-with-history prompt initial hist)))) + (format prompt (dired-mark-prompt arg files)) initial)) + + +;;;; ---------------------------------------------------------- +;;;; Marking files. +;;;; ---------------------------------------------------------- + +(defun dired-mark (arg &optional char) + "Mark the current (or next ARG) files. +If on a subdir headerline, mark all its files except `.' and `..'. + +Use \\[dired-unmark-all-files] to remove all marks, +and \\[dired-unmark] to remove the mark of the current file." + (interactive "p") + (if (dired-get-subdir) + (dired-mark-subdir-files char) + (dired-mark-file arg char))) + +(defun dired-mark-file (arg &optional char) + "Mark ARG files starting from the current file line. +Optional CHAR indicates a marker character to use." + (let (buffer-read-only) + (if (memq (or char dired-marker-char) '(?\ ?\n ?\r)) + (error "Invalid marker charcter %c" dired-marker-char)) + (or char (setq char dired-marker-char)) + (dired-repeat-over-lines + arg + (function + (lambda () + (dired-update-marker-counters (following-char) t) + (dired-substitute-marker (point) (following-char) char) + (dired-update-marker-counters char)))) + (dired-update-mode-line-modified))) + +(defun dired-mark-subdir-files (&optional char) + "Mark all files except `.' and `..'." + (interactive) + (save-excursion + (dired-mark-files-in-region (dired-subdir-min) (dired-subdir-max) char))) + +(defun dired-unmark (arg) + "Unmark the current (or next ARG) files. +If looking at a subdir, unmark all its files except `.' and `..'." + (interactive "p") + (let (buffer-read-only) + (dired-repeat-over-lines + arg + (function + (lambda () + (let ((char (following-char))) + (or (memq char '(?\ ?\n ?\r)) + (progn + (cond + ((char-equal char dired-marker-char) + (setq dired-marks-number (max (1- dired-marks-number) 0))) + ((char-equal char dired-del-marker) + (setq dired-del-flags-number + (max (1- dired-del-flags-number) 0))) + ((setq dired-other-marks-number + (max (1- dired-other-marks-number) 0)))) + (dired-substitute-marker (point) char ?\ ))))))) + (dired-update-mode-line-modified))) + +(defun dired-mark-prefix (&optional arg) + "Mark the next ARG files with the next character typed. +If ARG is negative, marks the previous files." + (interactive "p") + (if (sit-for echo-keystrokes) + (cond + ((or (= arg 1) (zerop arg)) + (message "Mark with character?")) + ((< arg 0) + (message "Mark %d file%s moving backwards?" + (- arg) (dired-plural-s (- arg)))) + ((> arg 1) + (message "Mark %d following files with character?" arg)))) + (dired-mark arg (read-char))) + +(defun dired-change-marks (old new) + "Change all OLD marks to NEW marks. +OLD and NEW are both characters used to mark files. +With a prefix, prompts for a mark to toggle. In other words, all unmarked +files receive that mark, and all files currently marked with that mark become +unmarked." + ;; When used in a lisp program, setting NEW to nil means toggle the mark OLD. + (interactive + (let* ((cursor-in-echo-area t) + (old nil) + (new nil) + (markers (dired-mark-list)) + (default (cond ((null markers) + (error "No markers in buffer")) + ((= (length markers) 1) + (setq old (car markers))) + ((memq dired-marker-char markers) + dired-marker-char) + ;; picks the last one in the buffer. reasonable? + ((car markers))))) + (or old (setq old + (progn + (if current-prefix-arg + (message "Toggle mark (default %c): " default) + (message "Change old mark (default %c): " default)) + (read-char)))) + (if (memq old '(?\ ?\n ?\r)) (setq old default)) + (or current-prefix-arg + (setq new (progn + (message + "Change %c marks to new mark (RET means abort): " old) + (read-char)))) + (list old new))) + (let ((old-count (cond + ((char-equal old dired-marker-char) + 'dired-marks-number) + ((char-equal old dired-del-marker) + 'dired-del-flags-number) + ('dired-other-marks-number)))) + (if new + (or (memq new '(?\ ?\n ?\r)) + ;; \n and \r aren't valid marker chars. Assume that if the + ;; user hits return, he meant to abort the command. + (let ((string (format "\n%c" old)) + (new-count (cond + ((char-equal new dired-marker-char) + 'dired-marks-number) + ((char-equal new dired-del-marker) + 'dired-del-flags-number) + ('dired-other-marks-number))) + (buffer-read-only nil)) + (save-excursion + (goto-char (point-min)) + (while (search-forward string nil t) + (if (char-equal (preceding-char) old) + (progn + (dired-substitute-marker (1- (point)) old new) + (set new-count (1+ (symbol-value new-count))) + (set old-count (max (1- (symbol-value old-count)) 0)))) + )))) + (save-excursion + (let ((ucount 0) + (mcount 0) + (buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (or (dired-between-files) + (looking-at dired-re-dot) + (cond + ((= (following-char) ?\ ) + (setq mcount (1+ mcount)) + (set old-count (1+ (symbol-value old-count))) + (dired-substitute-marker (point) ?\ old)) + ((= (following-char) old) + (setq ucount (1+ ucount)) + (set old-count (max (1- (symbol-value old-count)) 0)) + (dired-substitute-marker (point) old ?\ )))) + (forward-line 1)) + (message "Unmarked %d file%s; marked %d file%s with %c." + ucount (dired-plural-s ucount) mcount + (dired-plural-s mcount) old))))) + (dired-update-mode-line-modified)) + +(defun dired-unmark-all-files (flag &optional arg) + "Remove a specific mark or any mark from every file. +With prefix arg, query for each marked file. +Type \\[help-command] at that time for help. +With a zero prefix, only counts the number of marks." + (interactive + (let* ((cursor-in-echo-area t) + executing-kbd-macro) ; for XEmacs + (list (and (not (eq current-prefix-arg 0)) + (progn (message "Remove marks (RET means all): ") (read-char))) + current-prefix-arg))) + (save-excursion + (let* ((help-form "\ +Type SPC or `y' to unflag one file, DEL or `n' to skip to next, +`!' to unflag all remaining files with no more questions.") + (allp (memq flag '(?\n ?\r))) + (count-p (eq arg 0)) + (count (if (or allp count-p) + (mapcar + (function + (lambda (elt) + (cons elt 0))) + (nreverse (dired-mark-list))) + 0)) + (msg "") + (no-query (or (not arg) count-p)) + buffer-read-only case-fold-search query) + (goto-char (point-min)) + (if (or allp count-p) + (while (re-search-forward dired-re-mark nil t) + (if (or no-query + (dired-query 'query "Unmark file `%s'? " + (dired-get-filename t))) + (let ((ent (assq (preceding-char) count))) + (if ent (setcdr ent (1+ (cdr ent)))) + (or count-p (dired-substitute-marker + (- (point) 1) (preceding-char) ?\ )))) + (forward-line 1)) + (while (search-forward (format "\n%c" flag) nil t) + (if (or no-query + (dired-query 'query "Unmark file `%s'? " + (dired-get-filename t))) + (progn + (dired-substitute-marker (match-beginning 0) flag ?\ ) + (setq count (1+ count)))))) + (if (or allp count-p) + (mapcar + (function + (lambda (elt) + (or (zerop (cdr elt)) + (setq msg (format "%s%s%d %c%s" + msg + (if (zerop (length msg)) + " " + ", ") + (cdr elt) + (car elt) + (if (= 1 (cdr elt)) "" "'s")))))) + count) + (or (zerop count) + (setq msg (format " %d %c%s" + count flag (if (= 1 count) "" "'s"))))) + (if (zerop (length msg)) + (setq msg " none") + (or count-p (dired-update-mode-line-modified t))) + (message "%s:%s" (if count-p "Number of marks" "Marks removed") msg)))) + +(defun dired-get-marked-files (&optional localp arg) + "Return the marked files' names as list of strings. +The list is in the same order as the buffer, that is, the car is the + first marked file. +Values returned are normally absolute pathnames. +Optional arg LOCALP as in `dired-get-filename'. +Optional second argument ARG forces to use other files. If ARG is an + integer, use the next ARG files. If ARG is otherwise non-nil, use + current file. Usually ARG comes from the current prefix arg." + (save-excursion + (nreverse (dired-map-over-marks (dired-get-filename localp) arg)))) + +;;; Utility functions for marking files + +(defun dired-mark-files-in-region (start end &optional char) + (let (buffer-read-only) + (if (> start end) + (error "start > end")) + (goto-char start) ; assumed at beginning of line + (or char (setq char dired-marker-char)) + (while (< (point) end) + ;; Skip subdir line and following garbage like the `total' line: + (while (and (< (point) end) (dired-between-files)) + (forward-line 1)) + (if (and (/= (following-char) char) + (not (looking-at dired-re-dot)) + (save-excursion + (dired-move-to-filename nil (point)))) + (progn + (dired-update-marker-counters (following-char) t) + (dired-substitute-marker (point) (following-char) char) + (dired-update-marker-counters char))) + (forward-line 1))) + (dired-update-mode-line-modified)) + +(defun dired-mark-list () + ;; Returns a list of all marks currently used in the buffer. + (let ((result nil) + char) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (and (not (memq (setq char (following-char)) '(?\ ?\n ?\r))) + (not (memq char result)) + (setq result (cons char result))) + (forward-line 1))) + result)) + +;;; Dynamic markers + +(defun dired-set-current-marker-string () + "Computes and returns `dired-marker-string'." + (prog1 + (setq dired-marker-string + (if dired-marker-stack + (let* ((n (+ (length dired-marker-stack) 5)) + (str (make-string n ?\ )) + (list dired-marker-stack) + (pointer dired-marker-stack-pointer)) + (setq n (1- n)) + (aset str n ?\]) + (setq n (1- n)) + (while list + (aset str n (car list)) + (if (zerop pointer) + (progn + (setq n (1- n)) + (aset str n dired-marker-stack-cursor))) + (setq n (1- n) + pointer (1- pointer) + list (cdr list))) + (aset str n dired-default-marker) + (if (zerop pointer) + (aset str 2 dired-marker-stack-cursor)) + (aset str 1 ?\[) + str) + "")) + (set-buffer-modified-p (buffer-modified-p)))) + +(defun dired-set-marker-char (c) + "Set the marker character to something else. +Use \\[dired-restore-marker-char] to restore the previous value." + (interactive "cNew marker character: ") + (and (memq c '(?\ ?\n ?\r)) (error "invalid marker char %c" c)) + (setq dired-marker-stack (cons c dired-marker-stack) + dired-marker-stack-pointer 0 + dired-marker-char c) + (dired-update-mode-line-modified t) + (dired-set-current-marker-string)) + +(defun dired-restore-marker-char () + "Restore the marker character to its previous value. +Uses `dired-default-marker' if the marker stack is empty." + (interactive) + (setq dired-marker-stack (cdr dired-marker-stack) + dired-marker-char (car dired-marker-stack) + dired-marker-stack-pointer (min dired-marker-stack-pointer + (length dired-marker-stack))) + (or dired-marker-char + (setq dired-marker-char dired-default-marker)) + (dired-set-current-marker-string) + (dired-update-mode-line-modified t) + (or dired-marker-stack (message "Marker is %c" dired-marker-char))) + +(defun dired-marker-stack-left (n) + "Moves the marker stack cursor to the left." + (interactive "p") + (let ((len (1+ (length dired-marker-stack)))) + (or dired-marker-stack (error "Dired marker stack is empty.")) + (setq dired-marker-stack-pointer + (% (+ dired-marker-stack-pointer n) len)) + (if (< dired-marker-stack-pointer 0) + (setq dired-marker-stack-pointer (+ dired-marker-stack-pointer + len))) + (dired-set-current-marker-string) + (setq dired-marker-char + (if (= dired-marker-stack-pointer (1- len)) + dired-default-marker + (nth dired-marker-stack-pointer dired-marker-stack)))) + (dired-update-mode-line-modified t)) + +(defun dired-marker-stack-right (n) + "Moves the marker stack cursor to the right." + (interactive "p") + (dired-marker-stack-left (- n))) + +;;; Commands to mark or flag files based on their characteristics or names. + +(defun dired-mark-symlinks (&optional unflag-p) + "Mark all symbolic links. +With prefix argument, unflag all those files." + (interactive "P") + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (looking-at dired-re-sym) "symbolic link")) + (dired-update-mode-line-modified t)) + +(defun dired-mark-directories (&optional unflag-p) + "Mark all directory file lines except `.' and `..'. +With prefix argument, unflag all those files." + (interactive "P") + (if dired-re-dir + (progn + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (and (looking-at dired-re-dir) + (not (looking-at dired-re-dot))) + "directory file")))) + (dired-update-mode-line-modified t)) + +(defun dired-mark-executables (&optional unflag-p) + "Mark all executable files. +With prefix argument, unflag all those files." + (interactive "P") + (if dired-re-exe + (progn + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (looking-at dired-re-exe) "executable file")))) + (dired-update-mode-line-modified t)) + +(defun dired-flag-backup-files (&optional unflag-p) + "Flag all backup files (names ending with `~') for deletion. +With prefix argument, unflag these files." + (interactive "P") + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) + (dired-mark-if + (and (not (and dired-re-dir (looking-at dired-re-dir))) + (let ((fn (dired-get-filename t t))) + (if fn (backup-file-name-p fn)))) + "backup file")) + (dired-update-mode-line-modified t)) + +(defun dired-flag-auto-save-files (&optional unflag-p) + "Flag for deletion files whose names suggest they are auto save files. +A prefix argument says to unflag those files instead." + (interactive "P") + (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) + (dired-mark-if + ;; It is less than general to check for ~ here, + ;; but it's the only way this runs fast enough. + (and (save-excursion (end-of-line) + (eq (preceding-char) ?#)) + (not (and dired-re-dir (looking-at dired-re-dir))) + (let ((fn (dired-get-filename t t))) + (if fn (auto-save-file-name-p + (file-name-nondirectory fn))))) + "auto save file")) + (dired-update-mode-line-modified t)) + +(defun dired-mark-rcs-files (&optional unflag-p) + "Mark all files that are under RCS control. +With prefix argument, unflag all those files. +Mentions RCS files for which a working file was not found in this buffer. +Type \\[dired-why] to see them again." + ;; Returns failures, or nil on success. + ;; Finding those with locks would require to peek into the ,v file, + ;; depends slightly on the RCS version used and should be done + ;; together with the Emacs RCS interface. + ;; Unfortunately, there is no definitive RCS interface yet. + (interactive "P") + (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) + (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) + rcs-files wf failures count total) + (mapcar ; loop over subdirs + (function + (lambda (dir) + (or (equal (file-name-nondirectory (directory-file-name dir)) + "RCS") + ;; skip inserted RCS subdirs + (setq rcs-files + (append (directory-files dir t ",v$") ; *,v and RCS/*,v + (let ((rcs-dir (expand-file-name "RCS" dir))) + (if (file-directory-p rcs-dir) + (mapcar ; working files from ./RCS are in ./ + (function + (lambda (x) + (expand-file-name x dir))) + (directory-files + (file-name-as-directory rcs-dir) + nil ",v$")))) + rcs-files))))) + (mapcar (function car) dired-subdir-alist)) + (setq total (length rcs-files)) + (while rcs-files + (setq wf (substring (car rcs-files) 0 -2) + rcs-files (cdr rcs-files)) + (save-excursion (if (dired-goto-file wf) + (dired-mark 1) ; giving a prefix avoids checking + ; for subdir line. + (setq failures (cons wf failures))))) + (dired-update-mode-line-modified t) + (if (null failures) + (message "%d RCS file%s %smarked." + total (dired-plural-s total) (if unflag-p "un" "")) + (setq count (length failures)) + (dired-log-summary (buffer-name (current-buffer)) + "RCS working file not found %s" failures) + (message "%d RCS file%s: %d %smarked - %d not found %s." + total (dired-plural-s total) (- total count) + (if unflag-p "un" "") count failures)) + failures)) + + +;;;; ------------------------------------------------------------ +;;;; Logging failures +;;;; ------------------------------------------------------------ + +(defun dired-why () + "Pop up a buffer with error log output from Dired. +A group of errors from a single command ends with a formfeed. +Thus, use \\[backward-page] to find the beginning of a group of errors." + (interactive) + (if (get-buffer dired-log-buffer) + (let ((owindow (selected-window)) + (window (display-buffer (get-buffer dired-log-buffer)))) + (unwind-protect + (progn + (select-window window) + (goto-char (point-max)) + (recenter -1)) + (select-window owindow))))) + +(defun dired-log (buffer-name log &rest args) + ;; Log a message or the contents of a buffer. + ;; BUFFER-NAME is the name of the dired buffer to which the message applies. + ;; If LOG is a string and there are more args, it is formatted with + ;; those ARGS. Usually the LOG string ends with a \n. + ;; End each bunch of errors with (dired-log t): this inserts + ;; current time and buffer, and a \f (formfeed). + (or (stringp buffer-name) (setq buffer-name (buffer-name buffer-name))) + (let ((obuf (current-buffer))) + (unwind-protect ; want to move point + (progn + (set-buffer (get-buffer-create dired-log-buffer)) + (goto-char (point-max)) + (let (buffer-read-only) + (cond ((stringp log) + (insert (if args + (apply (function format) log args) + log))) + ((bufferp log) + (insert-buffer log)) + ((eq t log) + (insert "\n\t" (current-time-string) + "\tBuffer `" buffer-name "'\n\f\n"))))) + (set-buffer obuf)))) + +(defun dired-log-summary (buffer-name string failures) + (message (if failures "%s--type y for details %s" + "%s--type y for details") + string failures) + ;; Log a summary describing a bunch of errors. + (dired-log buffer-name (concat "\n" string)) + (if failures (dired-log buffer-name "\n%s" failures)) + (dired-log buffer-name t)) + + +;;;; ------------------------------------------------------- +;;;; Sort mode of dired buffers. +;;;; ------------------------------------------------------- + +(defun dired-sort-type (list) + ;; Returns the sort type of LIST, as a symbol. + (let* ((list (reverse list)) + (alist (sort + (mapcar (function + (lambda (x) + (cons (length (memq (car x) list)) (cdr x)))) + dired-sort-type-alist) + (function + (lambda (x y) + (> (car x) (car y)))))) + (winner (car alist))) + (if (zerop (car winner)) + 'name + (cdr winner)))) + +(defun dired-sort-set-modeline (&optional switches) + ;; Set modeline display according to dired-internal-switches. + ;; Modeline display of "by name" or "by date" guarantees the user a + ;; match with the corresponding regexps. Non-matching switches are + ;; shown literally. + (or switches (setq switches dired-internal-switches)) + (setq dired-sort-mode + (if dired-show-ls-switches + (concat " " (dired-make-switches-string + (or switches dired-internal-switches))) + (concat " by " (and (memq ?r switches) "rev-") + (symbol-name (dired-sort-type switches))))) + ;; update mode line + (set-buffer-modified-p (buffer-modified-p))) + +(defun dired-sort-toggle-or-edit (&optional arg) + "Toggle between sort by date/name for the current subdirectory. + +With a 0 prefix argument, simply reports on the current switches. + +With a prefix 1 allows the ls switches for the current subdirectory to be +edited. + +With a prefix 2 allows the default ls switches for newly inserted +subdirectories to be edited. + +With a prefix \\[universal-argument] allows you to sort the entire +buffer by either name or date. + +With a prefix \\[universal-argument] \\[universal-argument] allows the default switches +for the entire buffer to be edited, and then reverts the buffer so that all +subdirectories are sorted according to these switches. + +Note that although dired allows different ls switches to be used for +different subdirectories, certain combinations of ls switches are incompatible. +If incompatible switches are detected, dired will offer to revert the buffer +to force the ls switches for all subdirectories to a single value. If you +refuse to revert the buffer, any change of ls switches will be aborted." + (interactive "P") + (cond + ((eq arg 0) + ;; Report on switches + (message "Switches for current subdir: %s. Default for buffer: %s." + (dired-make-switches-string + (nth 3 (assoc (dired-current-directory) dired-subdir-alist))) + (dired-make-switches-string dired-internal-switches))) + ((null arg) + ;; Toggle between sort by date/name. + (let* ((dir (dired-current-directory)) + (curr (nth 3 (assoc dir dired-subdir-alist)))) + (dired-sort-other + (if (eq (dired-sort-type curr) 'name) + (cons ?t curr) + (mapcar (function + (lambda (x) + (setq curr + (delq (car x) curr)))) + dired-sort-type-alist) + curr) + nil dir))) + ((eq arg 1) + ;; Edit switches for current subdir. + (let* ((dir (dired-current-directory)) + (switch-string + (read-string + "New ls switches for current subdir (must contain -l): " + (dired-make-switches-string + (nth 3 (assoc dir dired-subdir-alist))))) + (switches (dired-make-switches-list switch-string))) + (if (dired-compatible-switches-p switches dired-internal-switches) + (dired-sort-other switches nil dir) + (if (or + (memq 'sort-revert dired-no-confirm) + (y-or-n-p + (format + "Switches %s incompatible with default %s. Revert buffer? " + switch-string + (dired-make-switches-string dired-internal-switches)))) + (dired-sort-other switches nil nil) + (error "Switches unchanged. Remain as %s." switch-string))))) + ((eq arg 2) + ;; Set new defaults for subdirs inserted in the future. + (let* ((switch-string + (read-string + "Default ls switches for new subdirs (must contain -l): " + (dired-make-switches-string dired-internal-switches))) + (switches (dired-make-switches-list switch-string)) + (alist dired-subdir-alist) + x bad-switches) + (while alist + (setq x (nth 3 (car alist)) + alist (cdr alist)) + (or (dired-compatible-switches-p x switches) + (member x bad-switches) + (setq bad-switches (cons x bad-switches)))) + (if bad-switches + (if (or (memq 'sort-revert dired-no-confirm) + (y-or-n-p + (format + "Switches %s incompatible with %s. Revert buffer? " + switch-string (mapconcat 'dired-make-switches-string + bad-switches ", ")))) + (dired-sort-other switches nil nil) + (error "Default switches unchanged. Remain as %s." + (dired-make-switches-string dired-internal-switches))) + (dired-sort-other switches t nil)))) + ((or (equal arg '(4)) (eq arg 'date) (eq arg 'name)) + ;; Toggle the entire buffer name/data. + (let ((cursor-in-echo-area t) + (switches (copy-sequence dired-internal-switches)) + (type (and (symbolp arg) arg)) + char) + (while (null type) + (message "Sort entire buffer according to (n)ame or (d)ate? ") + (setq char (read-char) + type (cond + ((char-equal char ?d) 'date) + ((char-equal char ?n) 'name) + (t (message "Type one of n or d.") (sit-for 1) nil)))) + (mapcar (function + (lambda (x) + (setq switches + (delq (car x) switches)))) + dired-sort-type-alist) + (dired-sort-other + (if (eq type 'date) (cons ?t switches) switches) nil nil))) + ((equal arg '(16)) + ;; Edit the switches for the entire buffer. + (dired-sort-other + (dired-make-switches-list + (read-string + "Change ls switches for entire buffer to (must contain -l): " + (dired-make-switches-string dired-internal-switches))) + nil nil)) + (t + ;; No idea what's going on. + (error + "Invalid prefix. See %s dired-sort-toggle-or-edit." + (substitute-command-keys + (if (featurep 'ehelp) + "\\[electric-describe-function]" + "\\[describe-function]")))))) + +(defun dired-sort-other (switches &optional no-revert subdir) + ;; Specify new ls SWITCHES for current dired buffer. + ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. + ;; If subdir is non-nil, only changes the switches for the + ;; sudirectory. + (if subdir + (let ((elt (assoc subdir dired-subdir-alist))) + (if elt (setcar (nthcdr 3 elt) switches))) + (setq dired-internal-switches switches)) + (or no-revert + (cond + + (subdir + (let ((ofile (dired-get-filename nil t)) + (opoint (point))) + (message "Relisting %s..." subdir) + (dired-insert-subdir subdir switches) + (message "Relisting %s... done" subdir) + (or (and ofile (dired-goto-file ofile)) (goto-char opoint)))) + + ((memq ?R switches) + ;; We are replacing a buffer with a giant recursive listing. + (let ((opoint (point)) + (ofile (dired-get-filename nil t)) + (hidden-subdirs (dired-remember-hidden)) + (mark-alist (dired-remember-marks (point-min) (point-max))) + (kill-files-p (save-excursion + (goto-char (point)) + (search-forward + (concat (char-to-string ?\r) + (regexp-quote + (char-to-string + dired-kill-marker-char))) + nil t))) + (omit-files (nth 2 (nth (1- (length dired-subdir-alist)) + dired-subdir-alist))) + buffer-read-only) + (dired-readin dired-directory (current-buffer) + (or (consp dired-directory) + (null (file-directory-p dired-directory)))) + (dired-mark-remembered mark-alist) ; mark files that were marked + (if kill-files-p (dired-do-hide dired-kill-marker-char)) + (if omit-files + (dired-omit-expunge nil t)) + ;; hide subdirs that were hidden + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + ;; Try to get back to where we were + (or (and ofile (dired-goto-file ofile)) + (goto-char opoint)) + (dired-move-to-filename))) + + (t + ;; Clear all switches in the subdir alist + (setq dired-subdir-alist + (mapcar (function + (lambda (x) + (setcar (nthcdr 3 x) nil) + x)) + dired-subdir-alist)) + (revert-buffer nil t)))) + (dired-update-mode-line t)) + +(defun dired-compatible-switches-p (list1 list2) + ;; Returns t if list1 and list2 are allowed as switches in the same + ;; dired buffer. + (and (eq (null (or (memq ?l list1) (memq ?o list1) (memq ?g list1))) + (null (or (memq ?l list2) (memq ?o list2) (memq ?g list2)))) + (eq (null (memq ?F list1)) (null (memq ?F list2))) + (eq (null (memq ?p list1)) (null (memq ?p list2))) + (eq (null (memq ?b list1)) (null (memq ?b list2))))) + +(defun dired-check-ls-l (&optional switches) + ;; Check for long-style listings + (let ((switches (or switches dired-internal-switches))) + (or (memq ?l switches) (memq ?o switches) (memq ?g switches) + (error "Dired needs -l, -o, or -g in ls switches")))) + + +;;;; -------------------------------------------------------------- +;;;; Creating new files. +;;;; -------------------------------------------------------------- +;;; +;;; The dired-create-files paradigm is used for copying, renaming, +;;; compressing, and making hard and soft links. + +(defun dired-file-marker (file) + ;; Return FILE's marker, or nil if unmarked. + (save-excursion + (and (dired-goto-file file) + (progn + (skip-chars-backward "^\n\r") + (and (not (= ?\040 (following-char))) + (following-char)))))) + +;; The basic function for half a dozen variations on cp/mv/ln/ln -s. +(defun dired-create-files (file-creator operation fn-list name-constructor + &optional marker-char query + implicit-to) + ;; Create a new file for each from a list of existing files. The user + ;; is queried, dired buffers are updated, and at the end a success or + ;; failure message is displayed + + ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists + ;; It is called for each file and must create newfile, the entry of + ;; which will be added. The user will be queried if the file already + ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a + ;; rename), it is FILE-CREATOR's responsibility to update dired + ;; buffers. FILE-CREATOR must abort by signalling a file-error if it + ;; could not create newfile. The error is caught and logged. + + ;; OPERATION (a capitalized string, e.g. `Copy') describes the + ;; operation performed. It is used for error logging. + + ;; FN-LIST is the list of files to copy (full absolute pathnames). + + ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to + ;; skip. If it skips files, it is supposed to tell why (using dired-log). + + ;; Optional MARKER-CHAR is a character with which to mark every + ;; newfile's entry, or t to use the current marker character if the + ;; oldfile was marked. + + ;; QUERY is a function to use to prompt the user about creating a file. + ;; It accepts two args, the from and to files, + ;; and must return nil or t. If QUERY is nil, then no user + ;; confirmation will be requested. + + ;; If IMPLICIT-TO is non-nil, then the file constructor does not take + ;; a to-file arg. e.g. compress. + + (let ((success-count 0) + (total (length fn-list)) + failures skipped overwrite-query) + ;; Fluid vars used for storing responses of previous queries must be + ;; initialized. + (dired-save-excursion + (setq dired-overwrite-backup-query nil + dired-file-creator-query nil) + (mapcar + (function + (lambda (from) + (let ((to (funcall name-constructor from))) + (if to + (if (equal to from) + (progn + (dired-log (buffer-name (current-buffer)) + "Cannot %s to same file: %s\n" + (downcase operation) from) + (setq skipped (cons (dired-make-relative from) skipped))) + (if (or (null query) + (funcall query from to)) + (let* ((overwrite (let (jka-compr-enabled) + ;; Don't let jka-compr fool us. + (file-exists-p to))) + ;; for dired-handle-overwrite + (dired-overwrite-confirmed + (and overwrite + (let ((help-form '(format "\ +Type SPC or `y' to overwrite file `%s', +DEL or `n' to skip to next, +ESC or `q' to not overwrite any of the remaining files, +`!' to overwrite all remaining files with no more questions." to))) + (dired-query 'overwrite-query + "Overwrite %s?" to)))) + ;; must determine if FROM is marked before + ;; file-creator gets a chance to delete it + ;; (in case of a move). + (actual-marker-char + (cond ((integerp marker-char) marker-char) + (marker-char (dired-file-marker from)) + (t nil)))) + (if (and overwrite (null dired-overwrite-confirmed)) + (setq skipped (cons (dired-make-relative from) + skipped)) + (condition-case err + (let ((dired-unhandle-add-files + (cons to dired-unhandle-add-files))) + (if implicit-to + (funcall file-creator from + dired-overwrite-confirmed) + (funcall file-creator from to + dired-overwrite-confirmed)) + (setq success-count (1+ success-count)) + (message "%s: %d of %d" + operation success-count total) + (dired-add-file to actual-marker-char)) + (file-error ; FILE-CREATOR aborted + (progn + (setq failures (cons (dired-make-relative from) + failures)) + (dired-log (buffer-name (current-buffer)) + "%s `%s' to `%s' failed:\n%s\n" + operation from to err)))))) + (setq skipped (cons (dired-make-relative from) skipped)))) + (setq skipped (cons (dired-make-relative from) skipped)))))) + fn-list) + (cond + (failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "%s failed for %d of %d file%s" + operation (length failures) total + (dired-plural-s total)) failures)) + (skipped + (dired-log-summary + (buffer-name (current-buffer)) + (format "%s: %d of %d file%s skipped" + operation (length skipped) total + (dired-plural-s total)) skipped)) + (t + (message "%s: %s file%s." + operation success-count (dired-plural-s success-count))))))) + +(defun dired-do-create-files (op-symbol file-creator operation arg + &optional marker-char + prompter how-to) + ;; Create a new file for each marked file. + ;; Prompts user for target, which is a directory in which to create + ;; the new files. Target may be a plain file if only one marked + ;; file exists. + ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' + ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. + ;; FILE-CREATOR and OPERATION as in dired-create-files. + ;; ARG as in dired-get-marked-files. + ;; PROMPTER is a function of one-arg, the list of files, to return a prompt + ;; to use for dired-read-file-name. If it is nil, then a default prompt + ;; will be used. + ;; Optional arg MARKER-CHAR as in dired-create-files. + ;; Optional arg HOW-TO determines how to treat target: + ;; If HOW-TO is not given (or nil), and target is a directory, the + ;; file(s) are created inside the target directory. If target + ;; is not a directory, there must be exactly one marked file, + ;; else error. + ;; If HOW-TO is t, then target is not modified. There must be + ;; exactly one marked file, else error. + ;; Else HOW-TO is assumed to be a function of one argument, target, + ;; that looks at target and returns a value for the into-dir + ;; variable. The function dired-into-dir-with-symlinks is provided + ;; for the case (common when creating symlinks) that symbolic + ;; links to directories are not to be considered as directories + ;; (as file-directory-p would if HOW-TO had been nil). + + (let* ((fn-list (dired-get-marked-files nil arg)) + (fn-count (length fn-list)) + (cdir (dired-current-directory)) + (target (expand-file-name + (dired-mark-read-file-name + (if prompter + (funcall prompter fn-list) + (concat operation " %s to: ")) + (dired-dwim-target-directory) + op-symbol arg (mapcar (function + (lambda (fn) + (dired-make-relative fn cdir t))) + fn-list)))) + (into-dir (cond ((null how-to) (file-directory-p target)) + ((eq how-to t) nil) + (t (funcall how-to target))))) + (if (and (> fn-count 1) + (not into-dir)) + (error "Marked %s: target must be a directory: %s" operation target)) + ;; rename-file bombs when moving directories unless we do this: + (or into-dir (setq target (directory-file-name target))) + (dired-create-files + file-creator operation fn-list + (if into-dir ; target is a directory + (list 'lambda '(from) + (list 'expand-file-name '(file-name-nondirectory from) target)) + (list 'lambda '(from) target)) + marker-char))) + +(defun dired-into-dir-with-symlinks (target) + (and (file-directory-p target) + (not (file-symlink-p target)))) +;; This may not always be what you want, especially if target is your +;; home directory and it happens to be a symbolic link, as is often the +;; case with NFS and automounters. Or if you want to make symlinks +;; into directories that themselves are only symlinks, also quite +;; common. +;; So we don't use this function as value for HOW-TO in +;; dired-do-symlink, which has the minor disadvantage of +;; making links *into* a symlinked-dir, when you really wanted to +;; *overwrite* that symlink. In that (rare, I guess) case, you'll +;; just have to remove that symlink by hand before making your marked +;; symlinks. + +(defun dired-handle-overwrite (to) + ;; Save old version of a to be overwritten file TO. + ;; `dired-overwrite-confirmed' and `dired-overwrite-backup-query' + ;; are fluid vars from dired-create-files. + (if (and dired-backup-if-overwrite + dired-overwrite-confirmed + (or (eq 'always dired-backup-if-overwrite) + (dired-query 'dired-overwrite-backup-query + (format "Make backup for existing file `%s'? " to)))) + (let ((backup (car (find-backup-file-name to)))) + (rename-file to backup 0)))) ; confirm overwrite of old backup + +(defun dired-dwim-target-directory () + ;; Try to guess which target directory the user may want. + ;; If there is a dired buffer displayed in the next window, use + ;; its current subdir, else use current subdir of this dired buffer. + ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode + (let* ((this-dir (and (eq major-mode 'dired-mode) + (dired-current-directory))) + (dwimmed + (if dired-dwim-target + (let* ((other-buf (window-buffer (next-window))) + (other-dir (save-excursion + (set-buffer other-buf) + (and (eq major-mode 'dired-mode) + (dired-current-directory))))) + (or other-dir this-dir)) + this-dir))) + (and dwimmed (dired-abbreviate-file-name dwimmed)))) + +(defun dired-get-target-directory () + "Writes a copy of the current subdirectory into an active minibuffer." + (interactive) + (let ((mb (dired-get-active-minibuffer-window))) + (if mb + (let ((dir (dired-current-directory))) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (error "No active minibuffer")))) + +;;; Copying files + +(defun dired-do-copy (&optional arg) + "Copy all marked (or next ARG) files, or copy the current file. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and the files are copied into that directory, retaining the same file names. + +A zero prefix argument copies nothing. But it toggles the +variable `dired-copy-preserve-time' (which see)." + (interactive "P") + (if (not (zerop (prefix-numeric-value arg))) + (dired-do-create-files 'copy (function dired-copy-file) + (if dired-copy-preserve-time "Copy [-p]" "Copy") + arg dired-keep-marker-copy) + (setq dired-copy-preserve-time (not dired-copy-preserve-time)) + (if dired-copy-preserve-time + (message "Copy will preserve time.") + (message "Copied files will get current date.")))) + +(defun dired-copy-file (from to ok-flag) + (dired-handle-overwrite to) + (copy-file from to ok-flag dired-copy-preserve-time)) + +;;; Renaming/moving files + +(defun dired-do-rename (&optional arg) + "Rename current file or all marked (or next ARG) files. +When renaming just the current file, you specify the new name. +When renaming multiple or marked files, you specify a directory. + +A zero ARG moves no files but toggles `dired-dwim-target' (which see)." + (interactive "P") + (if (not (zerop (prefix-numeric-value arg))) + (dired-do-create-files 'move (function dired-rename-file) + "Move" arg dired-keep-marker-rename + (function + (lambda (list) + (if (= (length list) 1) + "Rename %s to: " + "Move %s to: ")))) + (setq dired-dwim-target (not dired-dwim-target)) + (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) + +(defun dired-rename-file (from to ok-flag) + (dired-handle-overwrite to) + (let ((insert (assoc (file-name-as-directory from) dired-subdir-alist))) + (rename-file from to ok-flag) ; error is caught in -create-files + ;; Silently rename the visited file of any buffer visiting this file. + (dired-rename-update-buffers from to insert))) + +(defun dired-rename-update-buffers (from to &optional insert) + (if (get-file-buffer from) + (save-excursion + (set-buffer (get-file-buffer from)) + (let ((modflag (buffer-modified-p))) + (set-visited-file-name to) ; kills write-file-hooks + (set-buffer-modified-p modflag))) + ;; It's a directory. More work to do. + (let ((blist (buffer-list)) + (from-dir (file-name-as-directory from)) + (to-dir (file-name-as-directory to))) + (save-excursion + (while blist + (set-buffer (car blist)) + (setq blist (cdr blist)) + (cond + (buffer-file-name + (if (dired-in-this-tree buffer-file-name from-dir) + (let ((modflag (buffer-modified-p))) + (unwind-protect + (set-visited-file-name + (concat to-dir (substring buffer-file-name + (length from-dir)))) + (set-buffer-modified-p modflag))))) + (dired-directory + (if (string-equal from-dir (expand-file-name default-directory)) + ;; If top level directory was renamed, lots of things + ;; have to be updated. + (progn + (dired-unadvertise from-dir) + (setq default-directory to-dir + dired-directory + ;; Need to beware of wildcards. + (expand-file-name + (file-name-nondirectory dired-directory) + to-dir)) + (let ((new-name (file-name-nondirectory + (directory-file-name dired-directory)))) + ;; Try to rename buffer, but just leave old name if new + ;; name would already exist (don't try appending "<%d>") + ;; Why? --sandy 19-8-94 + (or (get-buffer new-name) + (rename-buffer new-name))) + (dired-advertise)) + (and insert + (assoc (file-name-directory (directory-file-name to)) + dired-subdir-alist) + (dired-insert-subdir to)))))))))) + +;;; Making symbolic links + +(defun dired-do-symlink (&optional arg) + "Make symbolic links to current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new symbolic links are made in that directory +with the same names that the files currently have." + (interactive "P") + (dired-do-create-files 'symlink (function make-symbolic-link) + "SymLink" arg dired-keep-marker-symlink)) + +;; Relative symlinks: +;; make-symbolic no longer expands targets (as of at least 18.57), +;; so the code to call ln has been removed. + +(defun dired-do-relsymlink (&optional arg) + "Symlink all marked (or next ARG) files into a directory, +or make a symbolic link to the current file. +This creates relative symbolic links like + + foo -> ../bar/foo + +not absolute ones like + + foo -> /ugly/path/that/may/change/any/day/bar/foo" + (interactive "P") + (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) + "RelSymLink" arg dired-keep-marker-symlink)) + +(defun dired-make-relative-symlink (target linkname + &optional ok-if-already-exists) + "Make a relative symbolic link pointing to TARGET with name LINKNAME. +Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS +The link is relative (if possible), for example + + \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" + +results in + + \"../../tex/bin/foo\" \"/vol/local/bin/foo\"" + (interactive + (let ((target (read-string "Make relative symbolic link to file: "))) + (list + target + (read-file-name (format "Make relsymlink to file %s: " target)) + 0))) + (let* ((target (expand-file-name target)) + (linkname (expand-file-name linkname)) + (handler (or (find-file-name-handler + linkname 'dired-make-relative-symlink) + (find-file-name-handler + target 'dired-make-relative-symlink)))) + (if handler + (funcall handler 'dired-make-relative-symlink target linkname + ok-if-already-exists) + (setq target (directory-file-name target) + linkname (directory-file-name linkname)) + (make-symbolic-link + (dired-make-relative target (file-name-directory linkname) t) + linkname ok-if-already-exists)))) + +;;; Hard links -- adding names to files + +(defun dired-do-hardlink (&optional arg) + "Add names (hard links) current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new hard links are made in that directory +with the same names that the files currently have." + (interactive "P") + (dired-do-create-files 'hardlink (function add-name-to-file) + "HardLink" arg dired-keep-marker-hardlink)) + + +;;;; --------------------------------------------------------------- +;;;; Running process on marked files +;;;; --------------------------------------------------------------- +;;; +;;; Commands for shell processes are in dired-shell.el. + +;;; Internal functions for running subprocesses, +;;; checking and logging of their errors. + +(defun dired-call-process (program discard &rest arguments) + ;; Run PROGRAM with output to current buffer unless DISCARD is t. + ;; Remaining arguments are strings passed as command arguments to PROGRAM. + ;; Returns program's exit status, as an integer. + ;; This is a separate function so that efs can redefine it. + (let ((return + (apply 'call-process program nil (not discard) nil arguments))) + (if (and (not (equal shell-file-name program)) + (integerp return)) + return + ;; Fudge return code by looking for errors in current buffer. + (if (zerop (buffer-size)) 0 1)))) + +(defun dired-check-process (msg program &rest arguments) + ;; Display MSG while running PROGRAM, and check for output. + ;; Remaining arguments are strings passed as command arguments to PROGRAM. + ;; On error, insert output in a log buffer and return the + ;; offending ARGUMENTS or PROGRAM. + ;; Caller can cons up a list of failed args. + ;; Else returns nil for success. + (let ((err-buffer (get-buffer-create " *dired-check-process output*")) + (dir default-directory)) + (message "%s..." msg) + (save-excursion + ;; Get a clean buffer for error output: + (set-buffer err-buffer) + (erase-buffer) + (setq default-directory dir) ; caller's default-directory + (if (not + (eq 0 (apply (function dired-call-process) program nil arguments))) + (progn + (dired-log (buffer-name (current-buffer)) + (concat program " " (prin1-to-string arguments) "\n")) + (dired-log (buffer-name (current-buffer)) err-buffer) + (or arguments program t)) + (kill-buffer err-buffer) + (message "%s...done" msg) + nil)))) + +;;; Changing file attributes + +(defun dired-do-chxxx (attribute-name program op-symbol arg) + ;; Change file attributes (mode, group, owner) of marked files and + ;; refresh their file lines. + ;; ATTRIBUTE-NAME is a string describing the attribute to the user. + ;; PROGRAM is the program used to change the attribute. + ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). + ;; ARG describes which files to use, like in dired-get-marked-files. + (let* ((files (dired-get-marked-files t arg)) + (new-attribute + (dired-mark-read-string + (concat "Change " attribute-name " of %s to: ") + nil op-symbol arg files)) + (operation (concat program " " new-attribute)) + (failures + (dired-bunch-files 10000 (function dired-check-process) + (list operation program new-attribute) + files))) + (dired-do-redisplay arg);; moves point if ARG is an integer + (if failures + (dired-log-summary (buffer-name (current-buffer)) + (format "%s: error" operation) nil)))) + +(defun dired-do-chmod (&optional arg) + "Change the mode of the marked (or next ARG) files. +This calls chmod, thus symbolic modes like `g+w' are allowed." + (interactive "P") + (dired-do-chxxx "Mode" "chmod" 'chmod arg)) + +(defun dired-do-chgrp (&optional arg) + "Change the group of the marked (or next ARG) files." + (interactive "P") + (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) + +(defun dired-do-chown (&optional arg) + "Change the owner of the marked (or next ARG) files." + (interactive "P") + (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) + +;;; Utilities for running processes on marked files. + +;; Process all the files in FILES in batches of a convenient size, +;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). +;; Batches are chosen to need less than MAX chars for the file names, +;; allowing 3 extra characters of separator per file name. +(defun dired-bunch-files (max function args files) + (let (pending + (pending-length 0) + failures) + ;; Accumulate files as long as they fit in MAX chars, + ;; then process the ones accumulated so far. + (while files + (let* ((thisfile (car files)) + (thislength (+ (length thisfile) 3)) + (rest (cdr files))) + ;; If we have at least 1 pending file + ;; and this file won't fit in the length limit, process now. + (if (and pending (> (+ thislength pending-length) max)) + (setq failures + (nconc (apply function (append args pending)) + failures) + pending nil + pending-length 0)) + ;; Do (setq pending (cons thisfile pending)) + ;; but reuse the cons that was in `files'. + (setcdr files pending) + (setq pending files) + (setq pending-length (+ thislength pending-length)) + (setq files rest))) + (nconc (apply function (append args pending)) + failures))) + + +;;;; --------------------------------------------------------------- +;;;; Calculating data or properties for marked files. +;;;; --------------------------------------------------------------- + +(defun dired-do-total-size (&optional arg) + "Show total size of all marked (or next ARG) files." + (interactive "P") + (let* ((result (dired-map-over-marks (dired-get-file-size) arg)) + (total (apply (function +) result)) + (num (length result))) + (message "%d bytes (%d kB) in %s file%s" + total (/ total 1024) num (dired-plural-s num)) + total)) + +(defun dired-get-file-size () + ;; Returns the file size in bytes of the current file, as an integer. + ;; Assumes that it is on a valid file line. It's the caller's responsibility + ;; to ensure this. Assumes that match 0 for dired-re-month-and-time is + ;; at the end of the file size. + (dired-move-to-filename t) + ;; dired-move-to-filename must leave match-beginning 0 at the start of + ;; the date. + (goto-char (match-beginning 0)) + (skip-chars-backward " ") + (string-to-int (buffer-substring (point) + (progn (skip-chars-backward "0-9") + (point))))) + +(defun dired-copy-filenames-as-kill (&optional arg) + "Copy names of marked (or next ARG) files into the kill ring. +The names are separated by a space, and may be copied into other buffers +with \\[yank]. The list of names is also stored in the variable +`dired-marked-files' for possible manipulation in the *scratch* buffer. + +With a 0 prefix argument, use the pathname relative to the top-level dired +directory for each marked file. + +With a prefix \\[universal-argument], use the complete pathname of each +marked file. + +With a prefix \\[universal-argument] \\[universal-argument], copy the complete +file line. In this case, the lines are separated by newlines. + +If on a subdirectory headerline and no prefix argument given, use the +subdirectory name instead." + (interactive "P") + (let (res) + (cond + ((and (null arg) (setq res (dired-get-subdir))) + (kill-new res) + (message "Copied %s into kill ring." res)) + ((equal arg '(16)) + (setq dired-marked-files + (dired-map-over-marks + (concat " " ; Don't copy the mark. + (buffer-substring + (progn (beginning-of-line) (1+ (point))) + (progn (skip-chars-forward "^\n\r") (point)))) + nil)) + (let ((len (length dired-marked-files))) + (kill-new (concat + (mapconcat 'identity dired-marked-files "\n") + "\n")) + (message "Copied %d file line%s into kill ring." + len (dired-plural-s len)))) + (t + (setq dired-marked-files + (cond + ((null arg) + (dired-get-marked-files 'no-dir)) + ((eq arg 0) + (dired-get-marked-files t)) + ((integerp arg) + (dired-get-marked-files 'no-dir arg)) + ((equal arg '(4)) + (dired-get-marked-files)) + (t (error "Invalid prefix %s" arg)))) + (let ((len (length dired-marked-files))) + (kill-new (mapconcat 'identity dired-marked-files " ")) + (message "Copied %d file name%s into kill ring." + len (dired-plural-s len))))))) + + +;;;; ----------------------------------------------------------- +;;;; Killing subdirectories +;;;; ----------------------------------------------------------- +;;; +;;; These commands actually remove text from the dired buffer. + +(defun dired-kill-subdir (&optional remember-marks tree) + "Remove all lines of current subdirectory. +Lower levels are unaffected. If given a prefix when called interactively, +kills the entire directory tree below the current subdirectory." + ;; With optional REMEMBER-MARKS, return a mark-alist. + (interactive (list nil current-prefix-arg)) + (let ((cur-dir (dired-current-directory))) + (if (string-equal cur-dir (expand-file-name default-directory)) + (error "Attempt to kill top level directory")) + (if tree + (dired-kill-tree cur-dir remember-marks) + (let ((beg (dired-subdir-min)) + (end (dired-subdir-max)) + buffer-read-only) + (prog1 + (if remember-marks (dired-remember-marks beg end)) + (goto-char beg) + (or (bobp) (forward-char -1)) ; gobble separator + (delete-region (point) end) + (dired-unsubdir cur-dir) + (dired-update-mode-line) + (dired-update-mode-line-modified t)))))) + +(defun dired-kill-tree (dirname &optional remember-marks) + "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. +With optional arg REMEMBER-MARKS, return an alist of marked files." + (interactive "DKill tree below directory: ") + (let ((s-alist dired-subdir-alist) dir m-alist) + (while s-alist + (setq dir (car (car s-alist)) + s-alist (cdr s-alist)) + (if (and (not (string-equal dir dirname)) + (dired-in-this-tree dir dirname) + (dired-goto-subdir dir)) + (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) + (dired-update-mode-line) + (dired-update-mode-line-modified t) + m-alist)) + + +;;;; ------------------------------------------------------------ +;;;; Killing file lines +;;;; ------------------------------------------------------------ +;;; +;;; Uses selective diplay, rather than removing lines from the buffer. + +(defun dired-do-kill-file-lines (&optional arg) + "Kill all marked file lines, or those indicated by the prefix argument. +Killing file lines means hiding them with selective display. Giving +a zero prefix redisplays all killed file lines." + (interactive "P") + (or selective-display + (error "selective-display must be t for file line killing to work!")) + (if (eq arg 0) + (dired-do-unhide dired-kill-marker-char + "Successfully resuscitated %d file line%s." + dired-keep-marker-kill) + (let ((files + (length + (dired-map-over-marks + (progn + (beginning-of-line) + (subst-char-in-region (1- (point)) (point) ?\n ?\r) + (dired-substitute-marker (point) (following-char) + dired-kill-marker-char) + (dired-update-marker-counters dired-marker-char t) + t) + arg)))) + ;; Beware of extreme apparent save-excursion lossage here. + (let ((opoint (point))) + (skip-chars-backward "^\n\r") + (if (= (preceding-char) ?\n) + (goto-char opoint) + (setq opoint (- opoint (point))) + (beginning-of-line) + (skip-chars-forward "^\n\r" (+ (point) opoint)))) + (dired-update-mode-line-modified) + (message "Killed %d file line%s." files (dired-plural-s files))))) + + +;;;; ---------------------------------------------------------------- +;;;; Omitting files. +;;;; ---------------------------------------------------------------- + +;; Marked files are never omitted. +;; Adapted from code submitted by: +;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 +;; Changed to work with selective display by Sandy Rutherford, 13/12/92. +;; For historical reasons, we still use the term expunge, although nothing +;; is expunged from the buffer. + +(defun dired-omit-toggle (&optional arg) + "Toggle between displaying and omitting files matching +`dired-omit-files-regexp' in the current subdirectory. +With a positive prefix, omits files in the entire tree dired buffer. +With a negative prefix, forces all files in the tree dired buffer to be +displayed." + (interactive "P") + (if arg + (let ((arg (prefix-numeric-value arg))) + (if (>= arg 0) + (dired-omit-expunge nil t) + (dired-do-unhide dired-omit-marker-char "") + (mapcar + (function + (lambda (elt) + (setcar (nthcdr 2 elt) nil))) + dired-subdir-alist))) + (if (dired-current-subdir-omitted-p) + (save-restriction + (narrow-to-region (dired-subdir-min) (dired-subdir-max)) + (dired-do-unhide dired-omit-marker-char "") + (setcar (nthcdr 2 (assoc + (dired-current-directory) dired-subdir-alist)) + nil) + (setq dired-subdir-omit nil)) + (dired-omit-expunge) + (setq dired-subdir-omit t))) + (dired-update-mode-line t)) + +(defun dired-current-subdir-omitted-p () + ;; Returns t if the current subdirectory is omited. + (nth 2 (assoc (dired-current-directory) dired-subdir-alist))) + +(defun dired-remember-omitted () + ;; Returns a list of omitted subdirs. + (let ((alist dired-subdir-alist) + result elt) + (while alist + (setq elt (car alist) + alist (cdr alist)) + (if (nth 2 elt) + (setq result (cons (car elt) result)))) + result)) + +(defun dired-omit-expunge (&optional regexp full-buffer) + ;; Hides all unmarked files matching REGEXP. + ;; If REGEXP is nil or not specified, uses `dired-omit-files-regexp', + ;; and also omits filenames ending in `dired-omit-extensions'. + ;; If REGEXP is the empty string, this function is a no-op. + (let ((omit-re (or regexp (dired-omit-regexp))) + (alist dired-subdir-alist) + elt min) + (if (null omit-re) + 0 + (if full-buffer + (prog1 + (dired-omit-region (point-min) (point-max) omit-re) + ;; Set omit property in dired-subdir-alist + (while alist + (setq elt (car alist) + min (dired-get-subdir-min elt) + alist (cdr alist)) + (if (and (<= (point-min) min) (>= (point-max) min)) + (setcar (nthcdr 2 elt) t)))) + (prog1 + (dired-omit-region (dired-subdir-min) (dired-subdir-max) omit-re) + (setcar + (nthcdr 2 (assoc (dired-current-directory) + dired-subdir-alist)) + t)))))) + +(defun dired-omit-region (start end regexp) + ;; Omits files matching regexp in region. Returns count. + (save-restriction + (narrow-to-region start end) + (let ((hidden-subdirs (dired-remember-hidden)) + buffer-read-only count) + (or selective-display + (error "selective-display must be t for file omission to work!")) + (dired-omit-unhide-region start end) + (let ((dired-marker-char dired-omit-marker-char) + ;; since all subdirs are now unhidden, this fakes + ;; dired-move-to-end-of-filename into working faster + (selective-display nil)) + (or dired-omit-silent + dired-in-query (message "Omitting...")) + (if (dired-mark-unmarked-files regexp nil nil 'no-dir) + (setq count (dired-do-hide + dired-marker-char + (and (memq dired-omit-silent '(nil 0)) + (not dired-in-query) + "Omitted %d line%s."))) + (or dired-omit-silent dired-in-query + (message "(Nothing to omit)")))) + (save-excursion ;hide subdirs that were hidden + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + count))) + +(defun dired-omit-unhide-region (beg end) + ;; Unhides hidden, but not marked files in the region. + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (and (char-equal (following-char) ?\ ) + (subst-char-in-region (1- (point)) (point) ?\r ?\n)))))) + +(defun dired-do-unhide (char &optional fmt marker) + ;; Unhides files marked with CHAR. Optional FMT is a message + ;; to be displayed. Note that after unhiding, we will need to re-hide + ;; files belonging to hidden subdirs. + (save-excursion + (goto-char (point-min)) + (let ((count 0) + (string (concat "\r" (char-to-string char))) + (hidden-subdirs (dired-remember-hidden)) + (new (if marker (concat "\n" (char-to-string marker)) "\n ")) + buffer-read-only) + (while (search-forward string nil t) + (replace-match new) + (setq count (1+ count))) + (or (equal "" fmt) + (message (or fmt "Unhid %d line%s.") count (dired-plural-s count))) + (goto-char (point-min)) + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1 t)))) + hidden-subdirs) + (if marker (dired-update-mode-line-modified t)) + count))) + +(defun dired-do-hide (char &optional fmt) + ;; Hides files marked with CHAR. Otional FMT is a message + ;; to be displayed. FMT is a format string taking args the number + ;; of hidden file lines, and dired-plural-s. + (save-excursion + (goto-char (point-min)) + (let ((count 0) + (string (concat "\n" (char-to-string char))) + buffer-read-only) + (while (search-forward string nil t) + (subst-char-in-region (match-beginning 0) + (1+ (match-beginning 0)) ?\n ?\r t) + (setq count (1+ count))) + (if fmt + (message fmt count (dired-plural-s count))) + count))) + +(defun dired-omit-regexp () + (let (rgxp) + (if dired-omit-extensions + (setq rgxp (concat + ".\\(" + (mapconcat 'regexp-quote dired-omit-extensions "\\|") + "\\)$"))) + (if dired-omit-regexps + (setq rgxp + (concat + rgxp + (and rgxp "\\|") + (mapconcat 'identity dired-omit-regexps "\\|")))) + rgxp)) + +(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) + ;; Marks unmarked files matching REGEXP, displaying MSG. + ;; REGEXP is matched against the complete pathname, unless localp is + ;; specified. + ;; Does not re-mark files which already have a mark. + ;; Returns t if any work was done, nil otherwise. + (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) + fn) + (dired-mark-if + (and + ;; not already marked + (eq (following-char) ?\ ) + ;; uninteresting + (setq fn (dired-get-filename localp t)) + (string-match regexp fn)) + msg))) + +(defun dired-add-omit-regexp (rgxp &optional how) + "Adds a new regular expression to the list of omit regular expresions. +With a non-zero numeric prefix argument, deletes a regular expresion from +the list. + +With a prefix argument \\[universal-argument], adds a new extension to +the list of file name extensions omitted. +With a prefix argument \\[universal-argument] \\[universal-argument], deletes +a file name extension from the list. + +With a prefix 0, reports on the current omit regular expressions and +extensions." + (interactive + (list + (cond + ((null current-prefix-arg) + (read-string "New omit regular expression: ")) + ((equal '(4) current-prefix-arg) + (read-string "New omit extension (\".\" is not implicit): ")) + ((equal '(16) current-prefix-arg) + (completing-read + "Remove from omit extensions (type SPACE for options): " + (mapcar 'list dired-omit-extensions) nil t)) + ((eq 0 current-prefix-arg) + nil) + (t + (completing-read + "Remove from omit regexps (type SPACE for options): " + (mapcar 'list dired-omit-regexps) nil t))) + current-prefix-arg)) + (let (remove) + (cond + ((null how) + (if (member rgxp dired-omit-regexps) + (progn + (describe-variable 'dired-omit-regexps) + (error "%s is already included in the list." rgxp)) + (setq dired-omit-regexps (cons rgxp dired-omit-regexps)))) + ((equal how '(4)) + (if (member rgxp dired-omit-extensions) + (progn + (describe-variable 'dired-omit-extensions) + (error "%s is already included in list." rgxp)) + (setq dired-omit-extensions (cons rgxp dired-omit-extensions)))) + ((equal how '(16)) + (let ((tail (member rgxp dired-omit-extensions))) + (if tail + (setq dired-omit-extensions + (delq (car tail) dired-omit-extensions) + remove t) + (setq remove 'ignore)))) + ((eq 0 how) + (setq remove 'ignore) + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (princ "Omit extensions (dired-omit-extensions ):\n") + (dired-format-columns-of-files dired-omit-extensions) + (princ "\n") + (princ "Omit regular expressions (dired-omit-regexps ):\n") + (dired-format-columns-of-files dired-omit-regexps) + nil))) + (with-output-to-temp-buffer "*Help*" + (princ "Omit extensions (dired-omit-extensions ):\n") + (dired-format-columns-of-files dired-omit-extensions) + (princ "\n") + (princ "Omit regular expressions (dired-omit-regexps ):\n") + (dired-format-columns-of-files dired-omit-regexps) + (print-help-return-message)))) + (t + (let ((tail (member rgxp dired-omit-regexps))) + (if tail + (setq dired-omit-regexps (delq (car tail) dired-omit-regexps) + remove t) + (setq remove 'ignore))))) + (or (eq remove 'ignore) + (save-excursion + (mapcar + (function + (lambda (dir) + (if (dired-goto-subdir dir) + (progn + (if remove + (save-restriction + (narrow-to-region + (dired-subdir-min) (dired-subdir-max)) + (dired-do-unhide dired-omit-marker-char ""))) + (dired-omit-expunge))))) + (dired-remember-omitted)))))) + + + +;;;; ---------------------------------------------------------------- +;;;; Directory hiding. +;;;; ---------------------------------------------------------------- +;;; +;;; To indicate a hidden subdir, we actually insert "..." in the buffer. +;;; Aside from giving the look of ellipses (even though +;;; selective-display-ellipses is nil), it allows us to tell the difference +;;; between a dir with a single omitted file, and a hidden subdir with one +;;; file. + +(defun dired-subdir-hidden-p (dir) + (save-excursion + (and selective-display + (dired-goto-subdir dir) + (looking-at "\\.\\.\\.\r")))) + +(defun dired-unhide-subdir () + (let (buffer-read-only) + (goto-char (dired-subdir-min)) + (skip-chars-forward "^\n\r") + (skip-chars-backward "." (- (point) 3)) + (if (looking-at "\\.\\.\\.\r") (delete-char 4)) + (dired-omit-unhide-region (point) (dired-subdir-max)))) + +(defun dired-hide-check () + (or selective-display + (error "selective-display must be t for subdir hiding to work!"))) + +(defun dired-hide-subdir (arg &optional really) + "Hide or unhide the current subdirectory and move to next directory. +Optional prefix arg is a repeat factor. +Use \\[dired-hide-all] to (un)hide all directories. +With the optional argument REALLY, we always hide +the subdir, regardless of dired-subdir-hidden-p." + ;; The arg REALLY is needed because when we unhide + ;; omitted files in a hidden subdir, we want to + ;; re-hide the subdir, regardless of whether dired + ;; thinks it's already hidden. + (interactive "p") + (dired-hide-check) + (dired-save-excursion + (while (>= (setq arg (1- arg)) 0) + (let* ((cur-dir (dired-current-directory)) + (hidden-p (and (null really) + (dired-subdir-hidden-p cur-dir))) + (elt (assoc cur-dir dired-subdir-alist)) + (end-pos (1- (dired-get-subdir-max elt))) + buffer-read-only) + ;; keep header line visible, hide rest + (goto-char (dired-get-subdir-min elt)) + (skip-chars-forward "^\n\r") + (skip-chars-backward "." (- (point) 3)) + (if hidden-p + (progn + (if (looking-at "\\.\\.\\.\r") + (progn + (delete-char 3) + (setq end-pos (- end-pos 3)))) + (dired-omit-unhide-region (point) end-pos)) + (if (looking-at "\\.\\.\\.\r") + (goto-char (match-end 0)) + (insert "...") + (setq end-pos (+ end-pos 3))) + (subst-char-in-region (point) end-pos ?\n ?\r))) + (dired-next-subdir 1 t)))) + +(defun dired-hide-all (arg) + "Hide all subdirectories, leaving only their header lines. +If there is already something hidden, make everything visible again. +Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." + (interactive "P") + (dired-hide-check) + (let (buffer-read-only) + (dired-save-excursion + (if (let ((alist dired-subdir-alist) + (hidden nil)) + (while (and alist (null hidden)) + (setq hidden (dired-subdir-hidden-p (car (car alist))) + alist (cdr alist))) + hidden) + ;; unhide + (let ((alist dired-subdir-alist)) + (while alist + (goto-char (dired-get-subdir-min (car alist))) + (skip-chars-forward "^\n\r") + (delete-region (point) (progn (skip-chars-backward ".") (point))) + (setq alist (cdr alist))) + (dired-omit-unhide-region (point-min) (point-max))) + ;; hide + (let ((alist dired-subdir-alist)) + (while alist + (dired-goto-subdir (car (car alist))) + (dired-hide-subdir 1 t) + (setq alist (cdr alist)))))))) + + +;;;; ----------------------------------------------------------------- +;;;; Automatic dired buffer maintenance. +;;;; ----------------------------------------------------------------- +;;; +;;; Keeping Dired buffers in sync with the filesystem and with each +;;; other. +;;; When used with efs on remote directories, buffer maintainence is +;;; done asynch. + +(defun dired-buffers-for-dir (dir-or-list &optional check-wildcard) +;; Return a list of buffers that dired DIR-OR-LIST +;; (top level or in-situ subdir). +;; The list is in reverse order of buffer creation, most recent last. +;; As a side effect, killed dired buffers for DIR are removed from +;; dired-buffers. If DIR-OR-LIST is a wildcard or list, returns any +;; dired buffers for which DIR-OR-LIST is equal to `dired-directory'. +;; If check-wildcard is non-nil, only returns buffers which contain dir-or-list +;; exactly, including the wildcard part. + (let ((alist dired-buffers) + (as-dir (and (stringp dir-or-list) + (file-name-as-directory dir-or-list))) + result buff elt) + (while alist + (setq buff (cdr (setq elt (car alist))) + alist (cdr alist)) + ;; dired-in-this-tree is not fast. It doesn't pay to use this to check + ;; whether the buffer is a good candidate. + (if (buffer-name buff) + (save-excursion + (set-buffer buff) + (if (or (equal dir-or-list dired-directory) ; the wildcard case. + (and as-dir + (not (and check-wildcard + (string-equal + as-dir + (expand-file-name default-directory)))) + (assoc as-dir dired-subdir-alist))) + (setq result (cons buff result)))) + ;; else buffer is killed - clean up: + (setq dired-buffers (delq elt dired-buffers)))) + (or dired-buffers (dired-remove-from-file-name-handler-alist)) + result)) + +(defun dired-advertise () + ;; Advertise in variable `dired-buffers' that we dired `default-directory'. + ;; With wildcards we actually advertise too much. + ;; Also makes sure that we are installed in the file-name-handler-alist + (prog1 + (let ((ddir (expand-file-name default-directory))) + (if (memq (current-buffer) (dired-buffers-for-dir ddir)) + t ; we have already advertised ourselves + (setq dired-buffers + (cons (cons ddir (current-buffer)) + dired-buffers)))) + ;; Do this last, otherwise the call to dired-buffers-for-dir will + ;; remove dired-handler-fn from the file-name-handler-alist. + ;; Strictly speaking, we only need to do this in th else branch of + ;; the if statement. We do it unconditionally as a sanity check. + (dired-check-file-name-handler-alist))) + +(defun dired-unadvertise (dir) + ;; Remove DIR from the buffer alist in variable dired-buffers. + ;; This has the effect of removing any buffer whose main directory is DIR. + ;; It does not affect buffers in which DIR is a subdir. + ;; Removing is also done as a side-effect in dired-buffer-for-dir. + (setq dired-buffers + (delq (assoc dir dired-buffers) dired-buffers)) + ;; If there are no more dired buffers, we are no longer needed in the + ;; file-name-handler-alist. + (or dired-buffers (dired-remove-from-file-name-handler-alist))) + +(defun dired-unadvertise-current-buffer () + ;; Remove all references to the current buffer in dired-buffers. + (setq dired-buffers + (delq nil + (mapcar + (function + (lambda (x) + (and (not (eq (current-buffer) (cdr x))) x))) + dired-buffers)))) + +(defun dired-fun-in-all-buffers (directory fun &rest args) + ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. + ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). + (let* ((buf-list (dired-buffers-for-dir directory)) + (obuf (current-buffer)) + (owin (selected-window)) + (win owin) + buf windows success-list) + (if buf-list + (unwind-protect + (progn + (while (not (eq (setq win (next-window win)) owin)) + (and (memq (setq buf (window-buffer win)) buf-list) + (progn + (set-buffer buf) + (= (point) (window-point win))) + (setq windows (cons win windows)))) + (while buf-list + (setq buf (car buf-list) + buf-list (cdr buf-list)) + (set-buffer buf) + (if (apply fun args) + (setq success-list (cons (buffer-name buf) success-list)))) + ;; dired-save-excursion prevents lossage of save-excursion + ;; for point. However, if dired buffers are displayed in + ;; other windows, the setting of window-point loses, and + ;; drags the point with it. This should fix this. + (while windows + (condition-case nil + (progn + (set-buffer (window-buffer (setq win (car windows)))) + (set-window-point win (point))) + (error nil)) + (setq windows (cdr windows)))) + (set-buffer obuf))) + success-list)) + +(defun dired-find-file-place (subdir file) + ;; Finds a position to insert in SUBDIR FILE. If it can't find SUBDIR, + ;; returns nil. + (let ((sort (dired-sort-type dired-internal-switches)) + (rev (memq ?r (nth 3 (assoc subdir dired-subdir-alist))))) + (cond + ((eq sort 'name) + (if (dired-goto-subdir subdir) + (let ((max (dired-subdir-max)) + start end found) + (if (dired-goto-next-file) + (progn + (skip-chars-forward "^\n\r") + (setq start (point)) + (goto-char (setq end max)) + (forward-char -1) + (skip-chars-backward "^\n\r") + ;; This loop must find a file. At the very least, it will + ;; find the one found previously. + (while (not found) + (if (save-excursion (dired-move-to-filename nil (point))) + (setq found t) + (setq end (point)) + (forward-char -1) + (skip-chars-backward "^\n\r"))) + (if rev + (while (< start end) + (goto-char (/ (+ start end) 2)) + (if (dired-file-name-lessp + (or (dired-get-filename 'no-dir t) + (error + "Error in dired-find-file-place")) + file) + (setq end (progn + (skip-chars-backward "^\n\r") + (point))) + (setq start (progn + (skip-chars-forward "^\n\r") + (forward-char 1) + (skip-chars-forward "^\n\r") + (point))))) + (while (< start end) + (goto-char (/ (+ start end) 2)) + (if (dired-file-name-lessp + file + (or (dired-get-filename 'no-dir t) + (error + "Error in dired-find-file-place"))) + (setq end (progn + (skip-chars-backward "^\n\r") + (point))) + (setq start (progn + (skip-chars-forward "^\n\r") + (forward-char 1) + (skip-chars-forward "^\n\r") + (point)))))) + (goto-char end)) + (goto-char max)) + t))) + ((eq sort 'date) + (if (dired-goto-subdir subdir) + (if rev + (goto-char (dired-subdir-max)) + (dired-goto-next-file) + t))) + ;; Put in support for other sorting types. + (t + (if (string-equal (dired-current-directory) subdir) + (progn + ;; We are already where we should be, except when + ;; point is before the subdir line or its total line. + (or (save-excursion (beginning-of-line) (dired-move-to-filename)) + (dired-goto-next-nontrivial-file)) ; in the header somewhere + t) ; return t, for found. + (if (dired-goto-subdir subdir) + (progn + (dired-goto-next-nontrivial-file) + t))))))) + +(defun dired-add-entry (filename &optional marker-char inplace) + ;; Add a new entry for FILENAME, optionally marking it + ;; with MARKER-CHAR (a character, else dired-marker-char is used). + ;; Hidden subdirs are exposed if a file is added there. + ;; + ;; This function now adds the new entry at the END of the previous line, + ;; not the beginning of the current line. + ;; Logically, we now think of the `newline' associated + ;; with a fileline, as the one at the beginning of the line, not the end. + ;; This makes it easier to keep track of omitted files. + ;; + ;; Uses dired-save-excursion, so that it doesn't move the + ;; point around. Especially important when it runs asynch. + ;; + ;; If there is already an entry, delete the existing one before adding a + ;; new one. In this case, doesn't remember its mark. Use + ;; dired-update-file-line for that. + ;; + ;; If INPLACE eq 'relist, then the new entry is put in the + ;; same place as the old, if there was an old entry. + ;; If INPLACE is t, then the file entry is put on the line + ;; currently containing the point. Otherwise, dired-find-file-place + ;; attempts to determine where to put the file. + + (setq filename (directory-file-name filename)) + (dired-save-excursion + (let ((oentry (save-excursion (dired-goto-file filename))) + (directory (file-name-directory filename)) + (file-nodir (file-name-nondirectory filename)) + buffer-read-only) + (if oentry + ;; Remove old entry + (let ((opoint (point))) + (goto-char oentry) + (delete-region (save-excursion + (skip-chars-backward "^\r\n") + (dired-update-marker-counters (following-char) t) + (1- (point))) + (progn + (skip-chars-forward "^\r\n") + (point))) + ;; Move to right place to replace deleted line. + (cond ((eq inplace 'relist) (forward-char 1)) + ((eq inplace t) (goto-char opoint))) + (dired-update-mode-line-modified))) + (if (or (eq inplace t) + (and oentry (eq inplace 'relist)) + ;; Tries to move the point to the right place. + ;; Returns t on success. + (dired-find-file-place directory file-nodir)) + (let ((switches (dired-make-switches-string + (cons ?d dired-internal-switches))) + b-of-l) + ;; Bind marker-char now, in case we are working asynch and + ;; dired-marker-char changes in the meantime. + (if (and marker-char (not (integerp marker-char))) + (setq marker-char dired-marker-char)) + ;; since we insert at the end of a line, + ;; backup to the end of the previous line. + (skip-chars-backward "^\n\r") + (forward-char -1) + (setq b-of-l (point)) + (if (and (featurep 'efs-dired) efs-dired-host-type) + ;; insert asynch + ;; we call the efs version explicitly here, + ;; rather than let the handler-alist work for us + ;; because we want to pass extra args. + ;; Is there a cleaner way to do this? + (efs-insert-directory filename ; don't expand `.' ! + switches nil nil + t ; nowait + marker-char) + (let ((insert-directory-program dired-ls-program)) + (insert-directory filename switches nil nil)) + (dired-after-add-entry b-of-l marker-char)) + (if dired-verify-modtimes + (dired-set-file-modtime directory dired-subdir-alist)) + t))))) ; return t on success, else nil. + +(defun dired-after-add-entry (start marker-char) + ;; Does the cleanup of a dired entry after listing it. + ;; START is the start of the new listing-line. + ;; This is a separate function for the sake of efs. + (save-excursion + (goto-char start) + ;; we make sure that the new line is bracketted by new-lines + ;; so the user doesn't need to use voodoo in the + ;; after-readin-hook. + (insert ?\n) + (dired-add-entry-do-indentation marker-char) + (let* ((beg (dired-manual-move-to-filename t)) + ;; error for strange output + (end (dired-manual-move-to-end-of-filename)) + (filename (buffer-substring beg end))) + ;; We want to have the non-directory part only. + (delete-region beg end) + ;; Any markers pointing to the beginning of the filename, will + ;; still point there after this insertion. Should keep + ;; save-excursion from losing. + (setq beg (point)) + (insert (file-name-nondirectory filename)) + (dired-insert-set-properties beg (point)) + (dired-move-to-filename)) + ;; The subdir-alist is not affected so we can run it right now. + (let ((omit (dired-current-subdir-omitted-p)) + (hide (dired-subdir-hidden-p (dired-current-directory)))) + (if (or dired-after-readin-hook omit hide) + (save-excursion + (save-restriction + ;; Use start so that we get the new-line at + ;; the beginning of the line in case we want + ;; to hide the file. Don't need to test (bobp) + ;; here, since we never add a file at + ;; the beginning of the buffer. + (narrow-to-region start + (save-excursion (forward-line 1) (point))) + (run-hooks 'dired-after-readin-hook) + (if omit + (let ((dired-omit-silent (or dired-omit-silent 0))) + (dired-omit-region (point-min) (point-max) + (dired-omit-regexp)))) + (if hide + (subst-char-in-region (point-min) (1- (point-max)) + ?\n ?\r)))))) + ;; clobber the extra newline at the end of the line + (end-of-line) + (delete-char 1))) + +;; This is a separate function for the sake of nested dired format. +(defun dired-add-entry-do-indentation (marker-char) + ;; two spaces or a marker plus a space: + (insert (if marker-char + (let ((char (if (integerp marker-char) + marker-char + dired-marker-char))) + (dired-update-marker-counters char) + (dired-update-mode-line-modified) + char) + ?\040) + ?\040)) + +(defun dired-remove-file (file) + (let ((alist dired-buffers) + buff) + (save-excursion + (while alist + (setq buff (cdr (car alist))) + (if (buffer-name buff) + (progn + (set-buffer buff) + (dired-remove-entry file)) + (setq dired-buffers (delq (car alist) dired-buffers))) + (setq alist (cdr alist)))) + (or dired-buffers (dired-remove-from-file-name-handler-alist)))) + +(defun dired-remove-entry (file) + (let ((ddir (expand-file-name default-directory)) + (dirname (file-name-as-directory file))) + (if (dired-in-this-tree ddir dirname) + (if (or (memq 'kill-dired-buffer dired-no-confirm) + (y-or-n-p (format "Kill dired buffer %s for %s, too? " + (buffer-name) dired-directory))) + (kill-buffer (current-buffer))) + (if (dired-in-this-tree file ddir) + (let ((alist dired-subdir-alist)) + (while alist + (if (dired-in-this-tree (car (car alist)) dirname) + (save-excursion + (goto-char (dired-get-subdir-min (car alist))) + (dired-kill-subdir))) + (setq alist (cdr alist))) + (dired-save-excursion + (and (dired-goto-file file) + (let (buffer-read-only) + (delete-region + (progn (skip-chars-backward "^\n\r") + (or (memq (following-char) '(\n \r ?\ )) + (progn + (dired-update-marker-counters + (following-char) t) + (dired-update-mode-line-modified))) + (1- (point))) + (progn (skip-chars-forward "^\n\r") (point))) + (if dired-verify-modtimes + (dired-set-file-modtime + (file-name-directory (directory-file-name file)) + dired-subdir-alist)))))))))) + +(defun dired-add-file (filename &optional marker-char) + (dired-fun-in-all-buffers + (file-name-directory filename) + (function dired-add-entry) filename marker-char)) + +(defun dired-relist-file (file) + (dired-uncache file nil) + (dired-fun-in-all-buffers (file-name-directory file) + (function dired-relist-entry) file)) + +(defun dired-relist-entry (file) + ;; Relist the line for FILE, or just add it if it did not exist. + ;; FILE must be an absolute pathname. + (let* ((file (directory-file-name file)) + (directory (file-name-directory file)) + (dd (expand-file-name default-directory))) + (if (assoc directory dired-subdir-alist) + (if (or + ;; Not a wildcard + (equal dd dired-directory) + ;; Not top-level + (not (string-equal directory dd)) + (and (string-equal directory + (if (consp dired-directory) + (file-name-as-directory + (car dired-directory)) + (file-name-directory dired-directory))) + (dired-file-in-wildcard-p dired-directory file))) + (let ((marker (save-excursion + (and (dired-goto-file file) + (dired-file-marker file))))) + ;; recompute omission + (if (eq marker dired-omit-marker-char) + (setq marker nil)) + (dired-add-entry file marker 'relist)) + ;; At least tell dired that we considered updating the buffer. + (if dired-verify-modtimes + (dired-set-file-modtime directory dired-subdir-alist)))))) + +(defun dired-file-in-wildcard-p (wildcard file) + ;; Return t if a file is part of the listing for wildcard. + ;; File should be the non-directory part only. + ;; This version is slow, but meticulously correct. Is it worth it? + (if (consp wildcard) + (let ((files (cdr wildcard)) + (dir (car wildcard)) + yep) + (while (and files (not yep)) + (setq yep (string-equal file (expand-file-name (car files) dir)) + files (cdr files))) + yep) + (let ((err-buff + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create " *dired-check-process output*"))) + (dir default-directory) + (process-connection-type nil)) + (save-excursion + (set-buffer err-buff) + (erase-buffer) + (setq default-directory dir) + (call-process shell-file-name nil t nil "-c" + (concat dired-ls-program " -d " wildcard " | " + "egrep '(^|/)" file "$'")) + (/= (buffer-size) 0))))) + +;; The difference between dired-add-file and dired-relist-file is that +;; the former creates the entry with a specific marker. The later preserves +;; existing markers on a per buffer basis. This is not the same as +;; giving dired-create-files a marker of t, which uses a marker in a specific +;; buffer to determine the marker for file line creation in all buffers. + + +;;;; ---------------------------------------------------------------- +;;;; Applying Lisp functions to marked files. +;;;; ---------------------------------------------------------------- + +;;; Running tags commands on marked files. +;; +;; Written 8/30/93 by Roland McGrath . +;; Requires tags.el as distributed with GNU Emacs 19.23, or later. + +(defun dired-do-tags-search (regexp) + "Search through all marked files for a match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]." + (interactive "sSearch marked files (regexp): ") + (tags-search regexp '(dired-get-marked-files))) + +(defun dired-do-tags-query-replace (from to &optional delimited) + "Query-replace-regexp FROM with TO through all marked files. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace +with the command \\[tags-loop-continue]." + (interactive + "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") + (tags-query-replace from to delimited '(dired-get-marked-files))) + +;;; byte compiling + +(defun dired-byte-compile () + ;; Return nil for success, offending file name else. + (let* ((filename (dired-get-filename)) + buffer-read-only failure) + (condition-case err + (save-excursion (byte-compile-file filename)) + (error + (setq failure err))) + ;; We should not need to update any file lines, as this will have + ;; already been done by after-write-region-hook. + (and failure + (progn + (dired-log (buffer-name (current-buffer)) + "Byte compile error for %s:\n%s\n" filename failure) + (dired-make-relative filename))))) + +(defun dired-do-byte-compile (&optional arg) + "Byte compile marked (or next ARG) Emacs lisp files." + (interactive "P") + (dired-map-over-marks-check (function dired-byte-compile) arg + 'byte-compile "byte-compile" t)) + +;;; loading + +(defun dired-load () + ;; Return nil for success, offending file name else. + (let ((file (dired-get-filename)) failure) + (condition-case err + (load file nil nil t) + (error (setq failure err))) + (if (not failure) + nil + (dired-log (buffer-name (current-buffer)) + "Load error for %s:\n%s\n" file failure) + (dired-make-relative file)))) + +(defun dired-do-load (&optional arg) + "Load the marked (or next ARG) Emacs lisp files." + (interactive "P") + (dired-map-over-marks-check (function dired-load) arg 'load "load" t)) + + +;;;; ---------------------------------------------------------------- +;;;; File Name Handler Alist +;;;; ---------------------------------------------------------------- +;;; +;;; Make sure that I/O functions maintain dired buffers. + +(defun dired-remove-from-file-name-handler-alist () + ;; Remove dired from the file-name-handler-alist + (setq file-name-handler-alist + (delq nil + (mapcar + (function + (lambda (x) + (and (not (eq (cdr x) 'dired-handler-fn)) + x))) + file-name-handler-alist)))) + +(defun dired-check-file-name-handler-alist () + ;; Verify that dired is installed as the first item in the alist + (or (eq (cdr (car file-name-handler-alist)) 'dired-handler-fn) + (setq file-name-handler-alist + (cons + '("." . dired-handler-fn) + (dired-remove-from-file-name-handler-alist))))) + +(defun dired-handler-fn (op &rest args) + ;; Function to update dired buffers after I/O. + (prog1 + (let ((inhibit-file-name-handlers + (cons 'dired-handler-fn + (and (eq inhibit-file-name-operation op) + inhibit-file-name-handlers))) + (inhibit-file-name-operation op)) + (apply op args)) + (let ((dired-omit-silent t) + (hf (get op 'dired))) + (and hf (funcall hf args))))) + +(defun dired-handler-fn-1 (args) + (let ((to (expand-file-name (nth 1 args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-2 (args) + (let ((from (expand-file-name (car args))) + (to (expand-file-name (nth 1 args)))) + ;; Don't remove the original entry if making backups. + ;; Otherwise we lose marks. I'm not completely happy with the + ;; logic here. + (or (and + (eq (nth 2 args) t) ; backups always have OK-IF-OVERWRITE t + (string-equal (car (find-backup-file-name from)) to)) + (dired-remove-file from)) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-3 (args) + (let ((to (expand-file-name (nth 2 args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-4 (args) + (dired-remove-file (expand-file-name (car args)))) + +(defun dired-handler-fn-5 (args) + (let ((to (expand-file-name (car args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-6 (args) + (let ((to (expand-file-name (nth 1 args))) + (old (expand-file-name (car args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)) + (dired-relist-file old))) + +(put 'copy-file 'dired 'dired-handler-fn-1) +(put 'dired-make-relative-symlink 'dired 'dired-handler-fn-1) +(put 'make-symbolic-link 'dired 'dired-handler-fn-1) +(put 'add-name-to-file 'dired 'dired-handler-fn-6) +(put 'rename-file 'dired 'dired-handler-fn-2) +(put 'write-region 'dired 'dired-handler-fn-3) +(put 'delete-file 'dired 'dired-handler-fn-4) +(put 'delete-directory 'dired 'dired-handler-fn-4) +(put 'dired-recursive-delete-directory 'dired 'dired-handler-fn-4) +(put 'make-directory-internal 'dired 'dired-handler-fn-5) +(put 'set-file-modes 'dired 'dired-handler-fn-5) + +;;;; ------------------------------------------------------------ +;;;; Autoload land. +;;;; ------------------------------------------------------------ + +;;; Reading mail (dired-xy) + +(autoload 'dired-read-mail "dired-xy" + "Reads the current file as a mail folder." t) +(autoload 'dired-vm "dired-xy" "Run VM on this file." t) +(autoload 'dired-rmail "dired-xy" "Run RMAIL on this file." t) + +;;; Virtual dired (dired-vir) + +(autoload 'dired-virtual "dired-vir" + "Put this buffer into virtual dired mode." t) + +;;; Grep (dired-grep) + +(autoload 'dired-do-grep "dired-grep" "Grep marked files for a pattern." t) + +;;; Doing diffs (dired-diff) + +(autoload 'dired-diff "dired-diff" + "Compare file at point with FILE using `diff'." t) +(autoload 'dired-backup-diff "dired-diff" + "Diff this file with its backup file or vice versa." t) +(autoload 'dired-emerge "dired-diff" + "Merge file at point with FILE using `emerge'." t) +(autoload 'dired-emerge-with-ancestor "dired-diff" + "Merge file at point with FILE, using a common ANCESTOR file." t) +(autoload 'dired-ediff "dired-diff" "Ediff file at point with FILE." t) +(autoload 'dired-epatch "dired-diff" "Patch file at point using `epatch'." t) + +;;; Shell commands (dired-shell) + +(autoload 'dired-do-print "dired-shell" "Print the marked (next ARG) files." t) +(autoload 'dired-run-shell-command "dired-shell" nil) +(autoload 'dired-do-shell-command "dired-shell" + "Run a shell command on the marked (or next ARG) files." t) +(autoload 'dired-do-background-shell-command "dired-shell" + "Run a background shell command on marked (or next ARG) files." t) + +;;; Commands using regular expressions (dired-rgxp) + +(autoload 'dired-mark-files-regexp "dired-rgxp" + "Mark all files whose names match REGEXP." t) +(autoload 'dired-flag-files-regexp "dired-rgxp" + "Flag for deletion all files whose names match REGEXP." t) +(autoload 'dired-mark-extension "dired-rgxp" + "Mark all files whose names have a given extension." t) +(autoload 'dired-flag-extension "dired-rgxp" + "Flag for deletion all files whose names have a given extension." t) +(autoload 'dired-cleanup "dired-rgxp" + "Flag for deletion dispensable files files created by PROGRAM." t) +(autoload 'dired-do-rename-regexp "dired-rgxp" + "Rename marked files whose names match a given regexp." t) +(autoload 'dired-do-copy-regexp "dired-rgxp" + "Copy marked files whose names match a given regexp." t) +(autoload 'dired-do-hardlink-regexp "dired-rgxp" + "Hardlink all marked files whose names match a regexp." t) +(autoload 'dired-do-symlink "dired-rgxp" + "Make a symbolic link to all files whose names match a regexp." t) +(autoload + 'dired-do-relsymlink-regexp "dired-rgxp" + "Make a relative symbolic link to all files whose names match a regexp." t) +(autoload 'dired-upcase "dired-rgxp" + "Rename all marked (or next ARG) files to upper case." t) +(autoload 'dired-downcase "dired-rgxp" + "Rename all marked (or next ARG) files to lower case." t) + +;;; Marking files from other buffers (dired-mob) + +(autoload 'dired-mark-files-from-other-dired-buffer "dired-mob" + "Mark files which are marked in another dired buffer." t) +(autoload 'dired-mark-files-compilation-buffer "dired-mob" + "Mark the files mentioned in the compilation buffer." t) + +;;; uuencoding (dired-uu) + +(autoload 'dired-do-uucode "dired-uu" "Uuencode or uudecode marked files." t) + +;;; Compressing (dired-cmpr) + +(autoload 'dired-do-compress "dired-cmpr" + "Compress or uncompress marked files." t) +(autoload 'dired-compress-subdir-files "dired-cmpr" + "Compress uncompressed files in the current subdirectory." t) + + +;;; Marking files according to sexps + +(autoload 'dired-mark-sexp "dired-sex" + "Mark files according to an sexpression." t) + +;;; Help! + +(autoload 'dired-summary "dired-help" + "Display summary of basic dired commands in the minibuffer." t) +(autoload 'dired-describe-mode "dired-help" + "Detailed description of dired mode. +With a prefix, runs the info documentation browser for dired." t) +(autoload 'dired-apropos "dired-help" + "Do command apropos help for dired commands. +With prefix does apropos help for dired variables." t) +(autoload 'dired-report-bug "dired-help" "Report a bug for dired." t) + +;;;; -------------------------------------------------------------- +;;;; Multi-flavour Emacs support +;;;; -------------------------------------------------------------- + +(let ((lucid-p (string-match "Lucid" emacs-version)) + ver) + (or (string-match "^\\([0-9]+\\)\\." emacs-version) + (error "Weird emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version (match-beginning 1) + (match-end 1)))) + + ;; Reading with history. + (if (>= ver 19) + + (defun dired-read-with-history (prompt initial history) + (read-from-minibuffer prompt initial nil nil history)) + + (defun dired-read-with-history (prompt initial history) + (let ((minibuffer-history-symbol history)) ; for gmhist + (read-string prompt initial)))) + + ;; Completing read with history. + (if (>= ver 19) + + (fset 'dired-completing-read 'completing-read) + + (defun dired-completing-read (prompt table &optional predicate + require-match initial-input history) + (let ((minibuffer-history-symbol history)) ; for gmhist + (completing-read prompt table predicate require-match + initial-input)))) + + ;; Abbreviating file names. + (if lucid-p + (fset 'dired-abbreviate-file-name + ;; Lemacs has this extra hack-homedir arg + (function + (lambda (fn) + (abbreviate-file-name fn t)))) + (fset 'dired-abbreviate-file-name 'abbreviate-file-name)) + + ;; Deleting directories + ;; Check for pre 19.8 versions of lucid emacs. + (if lucid-p + (or (fboundp 'delete-directory) + (fset 'delete-directory 'remove-directory))) + + ;; Minibuffers + (if (= ver 18) + + (defun dired-get-active-minibuffer-window () + (and (> (minibuffer-depth) 0) + (minibuffer-window))) + + (defun dired-get-active-minibuffer-window () + (let ((frames (frame-list)) + win found) + (while frames + (if (and (setq win (minibuffer-window (car frames))) + (minibuffer-window-active-p win)) + (setq found win + frames nil) + (setq frames (cdr frames)))) + found))) + + ;; Text properties and menus. + + (cond + (lucid-p + (require 'dired-xemacs)) + ((>= ver 19) + (require 'dired-fsf)) + (t + ;; text property stuff doesn't work in V18 + (fset 'dired-insert-set-properties 'ignore) + (fset 'dired-remove-text-properties 'ignore) + (fset 'dired-set-text-properties 'ignore) + (fset 'dired-move-to-filename 'dired-manual-move-to-filename) + (fset 'dired-move-to-end-of-filename + 'dired-manual-move-to-end-of-filename)))) + +;;; MULE + +(if (or (boundp 'MULE) (featurep 'mule)) (load "dired-mule")) + + +;; Run load hook for user customization. +(run-hooks 'dired-load-hook) + +;;; end of dired.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-auto.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-auto.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,51 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-auto.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Simple way of autoloading efs +;; Author: Andy Norman, Dawn +;; Created: Thu Sep 24 09:50:08 1992 +;; Modified: Sun Nov 27 11:45:28 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Provides a way of autoloading efs. To use this, just put +;;; (require 'efs-auto in your .emacs file. +;;; +;;; The Bad News: +;;; +;;; 1. Calls to load and require will not trigger efs to autoload. +;;; If you are want to put remote directories in your load path, +;;; you should require efs. +;;; 2. Because efs does not overload expand-file-name until it is loaded, +;;; "smart" expansion of file names on remote apollos running domain +;;; will not work yet. This means that accessing a file on a remote +;;; apollo may not correctly cause efs to autoload. This will depend +;;; the details of your command sequence. + +(provide 'efs-auto) +(require 'efs-ovwrt) +(require 'efs-fnh) + +(defconst efs-auto-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Interactive functions that should be accessible from here. + +(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) +(autoload + 'efs-set-passwd "efs-netrc" + "For a given HOST and USER, set or change the associated PASSWORD." t) +(autoload 'efs-nslookup-host "efs" + "Attempt to resolve a hostname using nslookup if possible." t) + +;;; end of efs-auto.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-cms-knet.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cms-knet.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,245 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cms-knet.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: CMS support for efs using KNET/VM server +;; Authors: Sandy Rutherford +;; Joerg-Martin Schwarz +;; Created: Wed Mar 23 14:39:00 1994 by schwarz on hal1 from efs-cms.el +;; Modified: Sun Nov 27 11:45:58 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cms-knet) +(require 'efs) + +(defconst efs-cms-knet-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; CMS support for KNET-VM server +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; CMS. It should be able to automatically recognize any CMS machine. +;;; We would be grateful if you would report any failures to automatically +;;; recognize a CMS host as a bug. +;;; +;;; Filename syntax: +;;; +;;; KNET/VM Support (J. M. Schwarz, Mar 12, 1994): +;;; This code has been developed and tested with +;;; "KNET/VM FTP server Release 3.2.0" by Spartacus. +;;; +;;; This server uses not only a different listing format than the one used in +;;; efs-cms.el, but also handles minidisks differently. +;;; The cd command for changing minidisk is not supported, +;;; instead a full filename syntax "FILENAME.FILETYPE.FM" is used, where +;;; FM is the filemode. To access a file "PROFILE EXEC A0", efs uses a +;;; syntax "/cms-hostname:/A:/PROFILE.EXEC" (Note the ':') +;;; +;;; In this directory notation, "/A0:" is actually a subset of the "/A:" +;;; directory. + +(efs-defun efs-send-pwd cms-knet (host user &optional xpwd) + ;; cms-knet has no concept of current directory. + ;; Is it safe to always assume this is the user's home? + (cons "A" "")) + +(efs-defun efs-fix-path cms-knet (path &optional reverse) + ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert + ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, + ;; so we fudge things by sending cd's. + (if reverse + ;; Since we only convert output from a pwd in this direction, + ;; this should never be applied, as PWD doesn't work for this server. + (concat "/" path "/") + (efs-save-match-data + (if (string-match "^/[A-Z]/\\([-A-Z0-9$_+@:]+\\.[-A-Z0-9$_+@:]+\\)$" + path) + (concat + (substring path (match-beginning 1) (match-end 1)) + "." + ;; minidisk + (substring path 1 2)) + (error "Invalid CMS-KNET filename"))))) + +(efs-defun efs-fix-dir-path cms-knet (dir-path) + ;; Convert path from UNIX-ish to CMS-KNET ready for a DIRectory listing. + (cond + ((string-equal "/" dir-path) + "*.*.*") + ((string-match + "^/[A-Z]/\\([-A-Z0-9$._+@:]+\\.[-A-Z0-9$._+@:]+\\)?$" + dir-path) + (concat + (if (match-beginning 1) + (substring dir-path (match-beginning 1) (match-end 1)) + "*") + "." + (substring dir-path 1 2))) + (t (error "Invalid CMS-KNET pathname")))) + +(defconst efs-cms-knet-file-name-regexp + (concat + "^ *\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +" + "\\([A-Z]\\)[0-9] +[VF] +[0-9]+ ")) + +(efs-defun efs-parse-listing cms-knet + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a CMS directory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory as a full efs-path + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-save-match-data + (if (string-equal dir "/") + (let ((case-fold (memq 'cms-knet efs-case-insensitive-host-types)) + tbl-alist md md-tbl) + (while (re-search-forward efs-cms-knet-file-name-regexp nil t) + (setq md (buffer-substring (match-beginning 3) (match-end 3)) + md-tbl (or (cdr (assoc md tbl-alist)) + (let ((new-tbl (efs-make-hashtable))) + (setq tbl-alist + (cons (cons md new-tbl) + tbl-alist)) + new-tbl))) + (efs-put-hash-entry md '(t) tbl) + (efs-put-hash-entry (concat + (buffer-substring (match-beginning 1) + (match-end 1)) + "." + (buffer-substring (match-beginning 2) + (match-end 2))) + '(nil) md-tbl) + (forward-line 1)) + (while tbl-alist + (setq md (car (car tbl-alist)) + md-tbl (cdr (car tbl-alist))) + (efs-put-hash-entry "." '(t) md-tbl) + (efs-put-hash-entry ".." '(t) md-tbl) + (efs-put-hash-entry (concat path md "/") md-tbl + efs-files-hashtable case-fold) + (setq tbl-alist (cdr tbl-alist)))) + (while (re-search-forward efs-cms-knet-file-name-regexp nil t) + (efs-put-hash-entry + (concat (buffer-substring (match-beginning 1) + (match-end 1)) + "." + (buffer-substring (match-beginning 2) + (match-end 2))) + '(nil) tbl) + (forward-line 1))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-allow-child-lookup cms-knet (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; CMS file system is flat. Only minidisks are "subdirs". + (string-equal "/" dir)) + +;;; Tree dired support: + +(defconst efs-dired-cms-re-exe + "^. +[-A-Z0-9$_+@:]+ +\\(EXEC\\|MODULE\\) " + "Regular expression to use to search for CMS executables.") + +(or (assq 'cms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'cms-knet efs-dired-cms-re-exe) + efs-dired-re-exe-alist))) + +(efs-defun efs-dired-insert-headerline cms-knet (dir) + ;; CMS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename cms-knet + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; This is the CMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-cms-knet-file-name-regexp eol t) + (goto-char (match-beginning 1)) + (if raise-error + (error "No file on this line.") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename cms-knet + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the CMS version. + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at "[-A-Z0-9$_+@:]+ +[-A-Z0-9$_+@:]+ +[A-Z][0-9] ") + (goto-char (- (match-end 0) 2)) ; return point + (if no-error + nil + (error "No file on this line.")))) + +(efs-defun efs-dired-get-filename cms-knet + (&optional localp no-error-if-not-filep) + (let ((name (efs-real-dired-get-filename 'no-dir no-error-if-not-filep))) + (and name + (if (string-match + "^\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +\\([A-Z]\\)$" + name) + (let* ((dir (dired-current-directory)) + (rdir (nth 2 (efs-ftp-path dir)))) + (setq name (concat (substring name (match-beginning 1) + (match-end 1)) + "." + (substring name (match-beginning 2) + (match-end 2)))) + (if (string-equal rdir "/") + (setq name (concat (substring name (match-beginning 3) + (match-end 3)) "/" name))) + (if (eq localp 'no-dir) + name + (concat (if localp + (dired-current-directory localp) + dir) + name))) + (error "Strange CMS-KNET file name %s" name))))) + +;;; end of efs-cms-knet.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-cms.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cms.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,462 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cms.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: CMS support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:52:00 1992 +;; Modified: Sun Nov 27 11:46:51 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cms) +(require 'efs) + +(defconst efs-cms-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; CMS support +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; CMS. It should be able to automatically recognize any CMS machine. +;;; We would be grateful if you would report any failures to automatically +;;; recognize a CMS host as a bug. +;;; +;;; This should also work with CMS machines running SFS (Shared File System). +;;; +;;; Filename syntax: +;;; +;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are +;;; treated as UNIX directories. For example to access the file READ.ME in +;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter +;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME +;;; If *.301 is the default minidisk for this account, you could access +;;; FOO.BAR on this minidisk as +;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR +;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be +;;; up to 8 characters. Again, beware that CMS filenames are always upper +;;; case, and hence must be entered as such. +;;; +;;; Tips: +;;; 1. CMS machines, with the exception of anonymous accounts, nearly always +;;; need an account password. To have efs send an account password, +;;; you can either include it in your .netrc file, or use +;;; efs-set-account. +;;; 2. efs-set-account can be used to set account passwords for specific +;;; minidisks. This is usually used to optain write access to the minidisk. +;;; As well you can put tokens of the form +;;; minidisk in your .netrc file. There can be +;;; as many minidisk tokens as you like, however they should follow all +;;; other tokens for a given machine entry. Of course, ordinary ftp +;;; will not understand these entries in your .netrc file. +;;; + + +;;; Since CMS doesn't have any full pathname syntax, we have to fudge +;;; things with cd's. We actually send too many cd's, but is dangerous +;;; to try to remember the current minidisk, because if the connection +;;; is closed and needs to be reopened, we will find ourselves back in +;;; the default minidisk. This is fairly likely since CMS ftp servers +;;; usually close the connection after 5 minutes of inactivity. + +;;; Have I got the filename character set right? + +;;; The following three functions are entry points to this file. +;;; They have been added to the appropriate alists in efs.el + +(efs-defun efs-fix-path cms (path &optional reverse) + ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert + ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, + ;; so we fudge things by sending cd's. + (efs-save-match-data + (if reverse + (if (string-match ":" path) + ;; It's SFS + (let* ((start (match-end 0)) + (return (concat "/" (substring path 0 start)))) + (while (string-match "\\." path start) + (setq return (concat return "/" + (substring path start + (match-beginning 0))) + start (match-end 0))) + (concat return "/" (substring path start))) + ;; Since we only convert output from a pwd in this direction, + ;; we'll assume that it's a minidisk, and make it into a + ;; directory file name. Note that the expand-dir-hashtable + ;; stores directories without the trailing /. + (if (char-equal (string-to-char path) ?/) + path + (concat "/" path))) + (if (let ((case-fold-search t)) + (string-match + (concat + "^/\\([-A-Z0-9$*._+:]+\\)/" + ;; In case there is a SFS + "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" + "\\([-A-Z0-9$._+]+\\)$") + path)) + (let ((minidisk (substring path 1 (match-end 1))) + (sfs (and (match-beginning 2) + (substring path (match-beginning 3) + (match-end 3)))) + (file (substring path (match-beginning 5) (match-end 5))) + account) + (and sfs (match-beginning 4) + (setq sfs (concat sfs "." (substring path (match-beginning 4) + (1- (match-end 4)))))) + (unwind-protect + (progn + (or sfs + (setq account + (efs-get-account host user minidisk))) + (efs-raw-send-cd host user (if sfs + (concat minidisk sfs ".") + minidisk)) + (if account + (efs-cms-send-minidisk-acct + host user minidisk account))) + (if account (fillarray account 0))) + file) + (error "Invalid CMS filename"))))) + +(efs-defun efs-fix-dir-path cms (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + (efs-save-match-data + (cond + ((string-equal "/" dir-path) + (error "Cannot get listing for CMS \"/\" directory.")) + ((let ((case-fold-search t)) + (string-match + (concat "^/\\([-A-Z0-9$*._+:]+\\)/" + "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" + "\\([-A-Z0-9$*_.+]+\\)?$") dir-path)) + (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) + (sfs (and (match-beginning 2) + (concat + (substring dir-path (match-beginning 3) + (match-end 3))))) + (file (if (match-beginning 5) + (substring dir-path (match-beginning 5) (match-end 5)) + "*")) + account) + (and sfs (match-beginning 4) + (setq sfs (concat sfs "." (substring dir-path + (match-beginning 4) + (1- (match-end 4)))))) + (unwind-protect + (progn + (or sfs + (setq account (efs-get-account host user minidisk))) + (efs-raw-send-cd host user (if sfs + (concat minidisk sfs ".") + minidisk)) + (if account + (efs-cms-send-minidisk-acct host user minidisk account))) + (if account (fillarray account 0))) + file)) + (t (error "Invalid CMS pathname"))))) + +(defconst efs-cms-file-line-regexp + (concat + "\\([-A-Z0-9$_+]+\\) +" + "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)")) + +(efs-defun efs-parse-listing cms + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a CMS directory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory as a full efs-path + (let ((tbl (efs-make-hashtable)) + fn dir-p) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward efs-cms-file-line-regexp nil t) + (if (match-beginning 3) + (setq fn (concat (buffer-substring + (match-beginning 1) (match-end 1)) + "." + (buffer-substring + (match-beginning 4) (match-end 4))) + dir-p nil) + (setq fn (buffer-substring (match-beginning 1) (match-end 1)) + dir-p t)) + (efs-put-hash-entry fn (list dir-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(defun efs-cms-send-minidisk-acct (host user minidisk account + &optional noretry) + "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given, +the account password is for that minidisk. If PROC is given, send to that +process, rathr than use HOST and USER to look up the process." + (efs-save-match-data + (let ((result (efs-raw-send-cmd + (efs-get-process host user) + (concat "quote acct " account)))) + (cond + ((eq (car result) 'failed) + (setq account nil) + (unwind-protect + (progn + (setq + account + (read-passwd + (format + "Invalid acct. password for %s on %s@%s. Try again: " + minidisk user host))) + (if (string-equal "" account) + (setq account nil))) + ;; This guarantees that an interrupt will clear the account + ;; password. + (efs-set-account host user minidisk account)) + (if account ; give the user another chance + (efs-cms-send-minidisk-acct host user minidisk account))) + ((eq (car result) 'fatal) + (if noretry + ;; give up + (efs-error host user + (concat "ACCOUNT password failed: " (nth 1 result))) + ;; try once more + (efs-cms-send-minidisk-acct host user minidisk account t)))) + ;; return result + result))) + +(efs-defun efs-write-recover cms + (line cont-lines host user cmd msg pre-cont cont nowait noretry) + ;; If a write fails because of insufficient privileges, give the user a + ;; chance to send an account password. + (let ((cmd0 (car cmd)) + (cmd1 (nth 1 cmd)) + (cmd2 (nth 2 cmd))) + (efs-save-match-data + (if (and (or (memq cmd0 '(append put rename)) + (and (eq cmd0 'quote) (eq cmd1 'stor))) + (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2)) + (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1))) + account retry) + (unwind-protect + (progn + (setq account + (read-passwd + (format "Account password for minidisk %s on %s@%s: " + minidisk user host))) + (if (string-equal account "") + (setq account nil))) + (efs-set-account host user minidisk account)) + (if account + (progn + (efs-cms-send-minidisk-acct host user minidisk account) + (setq retry + (efs-send-cmd host user cmd msg pre-cont cont + nowait noretry)) + (and (null (or cont nowait)) retry)) + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (and (null nowait) (list 'failed line cont-lines))))) + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (and (null nowait) (list 'failed line cont-lines))))))) + +(efs-defun efs-allow-child-lookup cms (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; CMS file system is flat. Only minidisks are "subdirs". + (or (string-equal "/" dir) + (efs-save-match-data + (string-match "^/[^/:]+:/$" dir)))) + +;;; Sorting listings + +(defconst efs-cms-date-and-time-regexp + (concat + " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +" + "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) ")) + +(efs-defun efs-t-converter cms (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-cms-date-and-time-regexp nil t) + (let (list-start list bol nbol) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq bol (point)) + (re-search-forward efs-cms-date-and-time-regexp + (setq nbol (save-excursion + (forward-line 1) (point))) + t)) + (setq list + (cons + (cons + (list (string-to-int (buffer-substring + (match-beginning 3) + (match-end 3))) ; year + (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1))) ; month + (string-to-int (buffer-substring + (match-beginning 2) + (match-end 2))) ; day + (string-to-int (buffer-substring + (match-beginning 4) + (match-end 4))) ; hour + (string-to-int (buffer-substring + (match-beginning 5) + (match-end 5))) ; minutes + (string-to-int (buffer-substring + (match-beginning 6) + (match-end 6)))) ; seconds + (buffer-substring bol nbol)) + list)) + (goto-char nbol)) + (if list + (progn + (setq list + (mapcar 'cdr + (sort list 'efs-cms-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list))) + t))))) + +(defun efs-cms-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minute1 (nth 4 data1)) + (minute2 (nth 4 data2)) + (second1 (nth 5 data1)) + (second2 (nth 5 data2))) + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (or (> minute1 minute2) + (and (= minute1 minute2) + (or (> (nth 5 data1) + (nth 5 data2))) + )))))))))))) + + +;;; Tree dired support: + +(defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ") + +(or (assq 'cms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'cms efs-dired-cms-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ") + +(or (assq 'cms efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'cms efs-dired-cms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline cms (dir) + ;; CMS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename cms + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; This is the CMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-cms-file-line-regexp eol t) + (goto-char (match-beginning 0)) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename cms + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the CMS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_+") + (or (looking-at " +DIR ") + (progn + (skip-chars-forward " ") + (skip-chars-forward "-A-Z0-9$_+"))) + (if (or (= opoint (point)) (/= (following-char) ?\ )) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-make-filename-string cms (filename &optional reverse) + (if reverse + (if (string-match "\\." filename) + ;; Can't count on the number of blanks between the base and the + ;; extension, so ignore the extension. + (substring filename 0 (match-beginning 0)) + filename) + (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename) + (concat (substring filename 0 (match-end 1)) + "." + (substring filename (match-beginning 2) (match-end 2))) + filename))) + +;;; end of efs-cms.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-coke.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-coke.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,176 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-coke.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Coke Machine support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 14 23:55:04 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 12:16:47 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-coke) +(require 'efs) + +(defconst efs-coke-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Coke Machine support +;;;; ------------------------------------------------------------ +;;; +;;; Works for the MIT vending machine FTP server. +;;; Hopefully, a vending machine RFC is on its way, so we won't +;;; need to support a wide variation of vending machine protocols. + +(efs-defun efs-send-pwd coke (host user &optional xpwd) + ;; Directories on vending machines? + "/") + +(efs-defun efs-fix-path coke (path &optional reverse) + (if (= ?/ (aref path 0)) + (if reverse path (substring path 1)) + (if reverse (concat "/" path) path))) + +(efs-defun efs-fix-dir-path coke (dir-path) + ;; Make a beverage path for a dir listing. + (if (or (string-equal dir-path "/") (string-equal dir-path "/.")) + "*" + dir-path)) + +(efs-defun efs-parse-listing coke + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in coke machine + ;; ftp dir format. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward "^\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\)" + nil t) + (efs-put-hash-entry (buffer-substring (match-beginning 2) + (match-end 2)) + (list nil) tbl) + (forward-line 1))) + ;; Don't need to bother with .. + (efs-put-hash-entry "." '(t) tbl) + tbl)) + +(efs-defun efs-allow-child-lookup coke (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Coke machine file system is flat. Hopefully not the coke. + (and (string-equal "/" dir) (string-equal "." file))) + +(defun efs-coke-insert-beverage-contents (buffer file line) + ;; Inserts the contents of a beverage (determined by the FTP server + ;; response LINE) into BUFFER, and then drinks it. + ;; FILE is the name of the file. + (efs-save-buffer-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (progn + (insert "\n\n\n\n " (substring line 4) "\n") + (set-buffer-modified-p nil) + (set-process-sentinel + (start-process "efs-coke-gulp-buffer" (current-buffer) "sleep" "3") + (function + (lambda (proc str) + (efs-save-buffer-excursion + (let ((buff (process-buffer proc))) + (and buff (get-buffer buff) + (progn + (set-buffer buff) + (erase-buffer) + (insert "\n\n\n\n GULP!!!\n") + (sit-for 1) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))))))))) + (if (featurep 'dired) + (dired-fun-in-all-buffers + (file-name-directory file) 'dired-revert))) + (message "You haven't finished your last drink in buffer %s!" + (current-buffer)) + (ding) + (sit-for 1)))) + +;;; Dired support + +(efs-defun efs-dired-manual-move-to-filename coke + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the COKE version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (looking-at "\\(. \\)?\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\): ") + (goto-char (match-beginning 3)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename coke + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the COKE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (search-forward ": " eol t) + (goto-char (- (match-end 0) 2)) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline coke (dir) + (let* ((parsed (efs-ftp-path dir)) + (host (car parsed)) + (user (nth 1 parsed)) + (accounting + (efs-send-cmd + host user '(quote pwd) + (format "Getting accounting data for %s@%s user host" user host)))) + (insert " " user "@" host "\n " + (if (car accounting) + "Account status unavailable" + (substring (nth 1 accounting) 4))) + (delete-region (point) (progn (skip-chars-backward ":.,;") (point))) + (insert ":\n \n"))) + +;;; end of efs-coke.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-cp-p.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cp-p.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,165 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cp-p.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for preserving file modtimes with copies. i.e. cp -p +;; Author: Sandy Rutherford +;; Created: Fri Feb 18 03:28:22 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 12:17:33 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cp-p) +(require 'efs) + +;;;; Internal Variables + +(defconst efs-cp-p-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-local-timezone nil) +;; cache. + +;;; Utility functions + +(efs-define-fun efs-gmt-time () + ;; Get the time as the number of seconds elapsed since midnight, + ;; Jan 1, 1970, GMT. Emacs 18 doesn't have `current-time' function. + (let ((time (current-time))) + (list (car time) (nth 1 time)))) + +(defun efs-local-time () + (let ((str (current-time-string))) + (efs-seconds-elapsed + (string-to-int (substring str -4)) + (cdr (assoc (substring str 4 7) efs-month-alist)) + (string-to-int (substring str 8 10)) + (string-to-int (substring str 11 13)) + (string-to-int (substring str 14 16)) + 0))) ; don't care about seconds + +(defun efs-local-timezone () + ;; Returns the local timezone as an integer. Right two digits the minutes, + ;; others the hours. + (or efs-local-timezone + (setq efs-local-timezone + (let* ((local (efs-local-time)) + (gmt (efs-gmt-time)) + (sign 1) + (diff (efs-time-minus local gmt)) + hours minutes) + ;; 2^16 is 36 hours. + (if (zerop (car diff)) + (setq diff (nth 1 diff)) + (error "Weird timezone!")) + (setq diff (/ (- (nth 1 local) (nth 1 gmt)) 60)) + (setq hours (/ diff 60)) + (setq minutes (% diff 60)) + (if (< diff 0) + (setq sign -1 + hours (- hours) + minutes (- minutes))) + ;; Round minutes + (setq minutes (* 10 (/ (+ minutes 5) 10))) + (if (= minutes 60) + (setq hours (1+ hours) + minutes 0)) + (* sign (+ (* hours 100) minutes)))))) + +(defun efs-last-day-of-month (month year) + ;; The last day in MONTH during YEAR. + ;; Taken from calendar.el. Thanks. + (if (and + (or + (and (= (% year 4) 0) + (/= (% year 100) 0)) ; leap-year-p + (= (% year 400) 0)) + (= month 2)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) + +(defun efs-make-date-local (year month day hour minutes seconds) + ;; Takes a GMT date (list of integers), and returns the local time. + (let* ((lzone (efs-local-timezone)) + (lminutes (% lzone 100)) + (lhour (/ lzone 100))) + (setq minutes (+ minutes lminutes)) + (cond ((> minutes 60) + (setq minutes (- minutes 60) + hour (1+ hour))) + ((< minutes 0) + (setq minutes (+ minutes 60) + hour (1- hour)))) + (setq hour (+ lhour hour)) + (if (or (< hour 0) (> hour 23)) + (progn + (cond ((< hour 0) + (setq hour (+ hour 24) + day (1- day))) + ((> hour 23) + (setq hour (- hour 24) + day (1+ day)))) + (if (or (zerop day) (> day + (efs-last-day-of-month month year))) + (cond ((zerop day) + (setq month (1- month)) + (if (zerop month) + (setq year (1- year) + month 12)) + (setq day (efs-last-day-of-month month year))) + ((> day (efs-last-day-of-month month year)) + (setq month (1+ month) + day 1) + (if (= month 13) + (setq year (1+ year) + month 1))))))) + (list year month day hour minutes seconds))) + +;;;; Entry function + +(defun efs-set-mdtm-of (filename newname &optional cont) + ;; NEWNAME must be local + ;; Always works NOWAIT = 0 + (let* ((parsed (efs-ftp-path filename)) + (host (car parsed)) + (user (nth 1 parsed)) + (file (nth 2 parsed))) + (if (efs-get-host-property host 'mdtm-failed) + (and cont (efs-call-cont cont 'failed "" "") nil) + (efs-send-cmd + host user + (list 'quote 'mdtm file) + nil nil + (efs-cont (result line cont-lines) (host newname cont) + (if (or result + (not (string-match efs-mdtm-msgs line))) + (efs-set-host-property host 'mdtm-failed t) + (let ((time (apply 'efs-make-date-local + (mapcar 'string-to-int + (list + (substring line 4 8) + (substring line 8 10) + (substring line 10 12) + (substring line 12 14) + (substring line 14 16) + (substring line 16 18)))))) + (if time + (call-process "touch" nil 0 nil "-t" + (format "%04d%02d%02d%02d%02d.%02d" + (car time) (nth 1 time) + (nth 2 time) (nth 3 time) + (nth 4 time) (nth 5 time)) + newname)))) + (if cont (efs-call-cont cont result line cont-lines))) + 0)))) + +;;; end of efs-cp-p.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-cu.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cu.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,635 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cu.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Common utilities needed by efs files. +;; Author: Sandy Rutherford +;; Created: Fri Jan 28 19:55:45 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;;; Provisions and autoloads. + +(provide 'efs-cu) +(require 'backquote) +(autoload 'efs-get-process "efs") +(autoload 'efs-parse-netrc "efs-netrc") + +;;;; ------------------------------------------------------------ +;;;; Use configuration variables. +;;;; ------------------------------------------------------------ + +(defvar efs-default-user nil + "*User name to use when none is specied in a pathname. + +If a string, than this string is used as the default user name. +If nil, then the name under which the user is logged in is used. +If t, then the user is prompted for a name. +If an association list of the form + + '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...) + +then the host name is tested against each of the regular expressions +REGEXP in turn, and the default user name is the corresponding value +of USERNAME. USERNAME may be either a string, nil, or t, and these +values are interpreted as above. If there are no matches, then the +user's curent login name is used.") + +(defvar efs-default-password nil + "*Password to use when the user is the same as efs-default-user.") + +(defvar efs-default-account nil + "*Account password to use when the user is efs-default-user.") + +;;;; ------------------------------------------------------------- +;;;; Internal variables. +;;;; ------------------------------------------------------------- + +(defconst efs-cu-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.2 $" 11 -2))) + +(defconst efs-case-insensitive-host-types + '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct + os2 hell guardian ms-unix netware cms-knet nos-ve) + "List of host types for which case is insignificant in file names.") + +;;; Remote path name syntax + +;; All of the following variables must be set consistently. +;; As well the below two functions depend on the grouping constructs +;; in efs-path-regexp. So know what you're doing if you change them. + +(defvar efs-path-regexp "^/\\([^@:/]*@\\)?\\([^@:/]*\\):.*" + "Regexp of a fully expanded remote path.") + +(defvar efs-path-format-string "/%s@%s:%s" + "Format of a fully expanded remote path. Passed to format with +additional arguments user, host, and remote path.") + +(defvar efs-path-format-without-user "/%s:%s" + "Format of a remote path, but not specifying a user.") + +(defvar efs-path-user-at-host-format + (substring efs-path-format-string 1 7) + "Format to return `user@host:' strings for completion in root directory.") + +(defvar efs-path-host-format + (substring efs-path-user-at-host-format 3) + "Format to return `host:' strings for completion in root directory.") + +(defvar efs-path-root-regexp "^/[^/:]+:" + "Regexp to match the `/user@host:' root of an efs full path.") + +(defvar efs-path-root-short-circuit-regexp "//[^/:]+:") +;; Regexp to match an efs user@host root, which short-circuits +;; the part of the path to the left of this pattern. + +;;;; ----------------------------------------------------------- +;;;; Variables for multiple host type support +;;;; ----------------------------------------------------------- + +(defvar efs-vms-host-regexp nil + "Regexp to match the names of hosts running VMS.") +(defvar efs-cms-host-regexp nil + "Regexp to match the names of hosts running CMS.") +(defvar efs-mts-host-regexp nil + "Regexp to match the names of hosts running MTS.") +(defvar efs-ti-explorer-host-regexp nil + "Regexp to match the names of hosts running TI-EXPLORER. +These are lisp machines.") +(defvar efs-ti-twenex-host-regexp nil + "Regexp to match the names of hosts running TI-TWENEX. +These are lisp machines, and this should not be confused with DEC's TOPS-20.") +(defvar efs-sysV-unix-host-regexp nil + "Regexp to match the names of sysV unix hosts. +These are defined to be unix hosts which mark symlinks +with a @ in an ls -lF listing.") +(defvar efs-bsd-unix-host-regexp nil + "Regexp to match the names of bsd unix hosts. +These are defined to be unix hosts which do not mark symlinks +with a @ in an ls -lF listing.") +(defvar efs-next-unix-host-regexp nil + "Regexp to match names of NeXT unix hosts. +These are defined to be unix hosts which put a @ after the +destination of a symlink when doing ls -lF listing.") +(defvar efs-unix-host-regexp nil + "Regexp to match names of unix hosts. +I you know which type of unix, it is much better to set that regexp instead.") +(defvar efs-dumb-unix-host-regexp nil + "Regexp to match names of unix hosts which do not take ls switches. +For these hosts we use the \"dir\" command.") +(defvar efs-super-dumb-unix-host-regexp nil + "Regexp to match names of unix hosts with FTP servers that cannot do a PWD. +It is also assumed that these hosts do not accept ls switches, whether +or not this is actually true.") +(defvar efs-dos-host-regexp nil + "Regexp to match names of hosts running DOS.") +;; In principal there is apollo unix support -- at least efs +;; should do the right thing. However, apollo ftp servers can be +;; very flakey, especially about accessing files by fullpaths. +;; Good luck. +(defvar efs-apollo-unix-host-regexp nil + "Regexp to match names of apollo unix hosts running Apollo's Domain. +For these hosts we don't short-circuit //'s immediately following +\"/user@host:\"") +(defvar efs-mvs-host-regexp nil + "Regexp to match names of hosts running MVS.") +(defvar efs-tops-20-host-regexp nil + "Regexp to match names of hosts runninf TOPS-20.") +(defvar efs-mpe-host-regexp nil + "Regexp to match hosts running the MPE operating system.") +(defvar efs-ka9q-host-regexp nil + "Regexp to match hosts using the ka9q ftp server. +These may actually be running one of DOS, LINUX, or unix.") +(defvar efs-dos-distinct-host-regexp nil + "Regexp to match DOS hosts using the Distinct FTP server. +These are not treated as DOS hosts with a special listing format, because +the Distinct FTP server uses unix-style path syntax.") +(defvar efs-os2-host-regexp nil + "Regexp to match names of hosts running OS/2.") +(defvar efs-vos-host-regexp nil + "Regexp to match hosts running the VOS operating system.") +(defvar efs-hell-host-regexp nil + "Regexp to match hosts using the hellsoft ftp server. +These map be either DOS PC's or Macs.") +;; The way that we implement the hellsoft support, it probably won't +;; work with Macs. This could probably be fixed, if enough people scream. +(defvar efs-guardian-host-regexp nil + "Regexp to match hosts running Tandem's guardian operating system.") +;; Note that ms-unix is really an FTP server running under DOS. +;; It's not a type of unix. +(defvar efs-ms-unix-host-regexp nil + "Regexp to match hosts using the Microsoft FTP server in unix mode.") +(defvar efs-plan9-host-regexp nil + "Regexp to match hosts running ATT's Plan 9 operating system.") +(defvar efs-cms-knet-host-regexp nil + "Regexp to match hosts running the CMS KNET FTP server.") +(defvar efs-nos-ve-host-regexp nil + "Regexp to match hosts running NOS/VE.") +(defvar efs-netware-host-regexp nil + "Regexp to match hosts running Novell Netware.") +(defvar efs-dumb-apollo-unix-regexp nil + "Regexp to match dumb hosts running Apollo's Domain. +These are hosts which do not accept switches to ls over FTP.") + +;;; Further host types: +;; +;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix, +;; next-unix, and dumb-unix. + +(defconst efs-host-type-alist + ;; When efs-add-host is called interactively, it will only allow + ;; host types from this list. + '((dumb-unix . efs-dumb-unix-host-regexp) + (super-dumb-unix . efs-super-dumb-unix-host-regexp) + (next-unix . efs-next-unix-host-regexp) + (sysV-unix . efs-sysV-unix-host-regexp) + (bsd-unix . efs-bsd-unix-host-regexp) + (apollo-unix . efs-apollo-unix-host-regexp) + (unix . efs-unix-host-regexp) + (vms . efs-vms-host-regexp) + (mts . efs-mts-host-regexp) + (cms . efs-cms-host-regexp) + (ti-explorer . efs-ti-explorer-host-regexp) + (ti-twenex . efs-ti-twenex-host-regexp) + (dos . efs-dos-host-regexp) + (mvs . efs-mvs-host-regexp) + (tops-20 . efs-tops-20-host-regexp) + (mpe . efs-mpe-host-regexp) + (ka9q . efs-ka9q-host-regexp) + (dos-distinct . efs-dos-distinct-host-regexp) + (os2 . efs-os2-host-regexp) + (vos . efs-vos-host-regexp) + (hell . efs-hell-host-regexp) + (guardian . efs-guardian-host-regexp) + (ms-unix . efs-ms-unix-host-regexp) + (plan9 . efs-plan9-host-regexp) + (cms-net . efs-cms-knet-host-regexp) + (nos-ve . efs-nos-ve-host-regexp) + (netware . efs-netware-host-regexp) + (dumb-apollo-unix . efs-dumb-apollo-unix-regexp))) + +;; host type cache +(defconst efs-host-cache nil) +(defconst efs-host-type-cache nil) + +;; cache for efs-ftp-path. +(defconst efs-ftp-path-arg "") +(defconst efs-ftp-path-res nil) + +;;;; ------------------------------------------------------------- +;;;; General macros. +;;;; ------------------------------------------------------------- + +(defmacro efs-save-match-data (&rest body) + "Execute the BODY forms, restoring the global value of the match data. +Before executing BODY, case-fold-search is locally bound to nil." + ;; Because Emacs is buggy about let-binding buffer-local variables, + ;; we have to do this in a slightly convoluted way. + (let ((match-data-temp (make-symbol "match-data")) + (buff-temp (make-symbol "buff")) + (cfs-temp (make-symbol "cfs"))) + (list + 'let (list (list match-data-temp '(match-data)) + (list buff-temp '(current-buffer)) + (list cfs-temp 'case-fold-search)) + (list 'unwind-protect + (cons 'progn + (cons + '(setq case-fold-search nil) + body)) + (list 'condition-case nil + (list 'save-excursion + (list 'set-buffer buff-temp) + (list 'setq 'case-fold-search cfs-temp)) + '(error nil)) + (list 'store-match-data match-data-temp))))) + +(put 'efs-save-match-data 'lisp-indent-hook 0) +(put 'efs-save-match-data 'edebug-form-spec '(&rest form)) + +(defmacro efs-define-fun (fun args &rest body) + "Like defun, but only defines a function if it has no previous definition." + ;; There are easier ways to do this. This approach is used so that the + ;; byte compiler won't complain about possibly undefined functions. + (` + (progn + (put (quote (, fun)) 'efs-define-fun + (and (fboundp (quote (, fun))) + (symbol-function (quote (, fun))))) + (defun (, fun) (, args) (,@ body)) + (if (and (get (quote (, fun)) 'efs-define-fun) + (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun)) + (quote autoload)))) + (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun))) + (put (quote (, fun)) 'efs-define-fun nil) + (quote (, fun))))) + +(put 'efs-define-fun 'lisp-indent-hook 'defun) + +(defmacro efs-quote-dollars (string) + ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.' + (` + (let ((string (, string)) + (pos 0)) + (while (setq pos (string-match "\\$" string pos)) + (setq string (concat (substring string 0 pos) + "$";; precede by escape character (also a $) + (substring string pos)) + ;; add 2 instead 1 since another $ was inserted + pos (+ 2 pos))) + string))) + +(defmacro efs-cont (implicit-args explicit-args &rest body) + "Defines an efs continuation function. +The IMPLICIT-ARGS are bound when the continuation function is called. +The EXPLICIT-ARGS are bound when the continuation function is set." + (let ((fun (list 'function + (cons 'lambda + (cons + (append implicit-args explicit-args) + body))))) + (if explicit-args + (cons 'list (cons fun explicit-args)) + fun))) + +(put 'efs-cont 'lisp-indent-hook 2) + +;;;; ------------------------------------------------------------ +;;;; Utility functions +;;;; ------------------------------------------------------------ + +(efs-define-fun efs-repaint-minibuffer () + ;; Set minibuf_message = 0, so that the contents of the minibuffer will show. + ;; This is the Emacs V19 version of this function. For Emacs 18, it will + ;; be redefined in a grotty way to accomplish the same thing. + (message nil)) + +(defun efs-get-user (host) + "Given a HOST, return the default USER." + (efs-parse-netrc) + ;; We cannot check for users case-insensitively on those systems + ;; which are treat usernames case-insens., because we need to log in + ;; first, before we know what type of system. + (let ((user (efs-get-host-property host 'user))) + (if (stringp user) + user + (prog1 + (setq user + (cond ((stringp efs-default-user) + ;; We have a default name. Use it. + efs-default-user) + ((consp efs-default-user) + ;; Walk the list looking for a host-specific value. + (efs-save-match-data + (let ((alist efs-default-user) + (case-fold-search t) + result) + (while alist + (if (string-match (car (car alist)) host) + (setq result (cdr (car alist)) + alist nil) + (setq alist (cdr alist)))) + (cond + ((stringp result) + result) + (result + (let ((enable-recursive-minibuffers t)) + (read-string (format "User for %s: " host) + (user-login-name)))) + (t + (user-login-name)))))) + (efs-default-user + ;; Ask the user. + (let ((enable-recursive-minibuffers t)) + (read-string (format "User for %s: " host) + (user-login-name)))) + ;; Default to the user's login name. + (t + (user-login-name)))) + (efs-set-user host user))))) + +(defun efs-ftp-path (path) + "Parse PATH according to efs-path-regexp. +Returns a list (HOST USER PATH), or nil if PATH does not match the format." + (or (string-equal path efs-ftp-path-arg) + (setq efs-ftp-path-res + (efs-save-match-data + (and (string-match efs-path-regexp path) + (let ((host (substring path (match-beginning 2) + (match-end 2))) + (user (and (match-beginning 1) + (substring path (match-beginning 1) + (1- (match-end 1))))) + (rpath (substring path (1+ (match-end 2))))) + (list (if (string-equal host "") + (setq host (system-name)) + host) + (or user (efs-get-user host)) + rpath)))) + ;; Set this last, in case efs-get-user calls this + ;; function, which would modify an earlier setting. + efs-ftp-path-arg path)) + efs-ftp-path-res) + +(defun efs-chase-symlinks (file) + ;; If FILE is a symlink, chase it until we get to a real file. + ;; Unlike file truename, this function does not chase symlinks at + ;; every level, only the bottom level. Therefore, it is not useful for + ;; obtaining the truename of a file. It is useful for getting at file + ;; attributes, with a lot less overhead than file truename. + (let ((target (file-symlink-p file))) + (if target + (efs-chase-symlinks + (expand-file-name target (file-name-directory file))) + file))) + +;; If efs-host-type is called with the optional user +;; argument, it will attempt to guess the host type by connecting +;; as user, if necessary. + +(defun efs-host-type (host &optional user) + "Return a symbol which represents the type of the HOST given. +If the optional argument USER is given, attempts to guess the +host-type by logging in as USER." + + (and host + (let ((host (downcase host)) + type) + (cond + + ((and efs-host-cache + (string-equal host efs-host-cache) + efs-host-type-cache)) + + ((setq type + (efs-get-host-property host 'host-type)) + (setq efs-host-cache host + efs-host-type-cache type)) + + ;; Trigger an ftp connection, in case we need to + ;; guess at the host type. + ((and user (efs-get-process host user) + (if (string-equal host efs-host-cache) + ;; logging in may update the cache + efs-host-type-cache + (and (setq type (efs-get-host-property host 'host-type)) + (setq efs-host-cache host + efs-host-type-cache type))))) + + ;; Try the regexps. + ((setq type + (let ((alist efs-host-type-alist) + regexp type-pair) + (catch 'match + (efs-save-match-data + (let ((case-fold-search t)) + (while alist + (progn + (and (setq type-pair (car alist) + regexp (eval (cdr type-pair))) + (string-match regexp host) + (throw 'match (car type-pair))) + (setq alist (cdr alist))))) + nil)))) + (setq efs-host-cache host + efs-host-type-cache type)) + ;; Return 'unknown, but _don't_ cache it. + (t 'unknown))))) + +;;;; ------------------------------------------------------------- +;;;; Functions and macros for hashtables. +;;;; ------------------------------------------------------------- + +(defun efs-make-hashtable (&optional size) + "Make an obarray suitable for use as a hashtable. +SIZE, if supplied, should be a prime number." + (make-vector (or size 31) 0)) + +(defun efs-map-hashtable (fun tbl &optional property) + "Call FUNCTION on each key and value in HASHTABLE. +If PROPERTY is non-nil, it is the property to be used as the second +argument to FUNCTION. The default property is 'val" + (let ((prop (or property 'val))) + (mapatoms + (function + (lambda (sym) + (funcall fun (symbol-name sym) (get sym prop)))) + tbl))) + +(defmacro efs-make-hash-key (key) + "Convert KEY into a suitable key for a hashtable. This returns a string." + (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the + ; point. + (if (stringp key) key (prin1-to-string key))))) + +;;; Note, if you store entries in a hashtable case-sensitively, and then +;;; retrieve them with IGNORE-CASE=t, it is possible that there may be +;;; be more than one entry that could be retrieved. It is more or less random +;;; which one you'll get. The onus is on the programmer to be consistent. +;;; Suggestions to make this faster are gratefully accepted! + +(defmacro efs-case-fold-intern-soft (name tbl) + "Returns a symbol with case-insensitive name NAME in the obarray TBL. +Case is considered insignificant in NAME. Note, if there is more than +one possible match, it is hard to predicate which one you'll get." + (` + (let* ((completion-ignore-case t) + (name (, name)) + (tbl (, tbl)) + (len (length (, name))) + (newname (try-completion name tbl + (function + (lambda (sym) + (= (length (symbol-name sym)) len)))))) + (and newname + (if (eq newname t) + (intern name tbl) + (intern newname tbl)))))) + +(defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case) + "Return whether there is an association for KEY in TABLE. +If optional IGNORE-CASE is non-nil, then ignore-case in the test." + (` (let ((key (efs-make-hash-key (, key)))) + (if (, ignore-case) + (efs-case-fold-intern-soft key (, tbl)) + (intern-soft key (, tbl)))))) + +(defmacro efs-get-hash-entry (key tbl &optional ignore-case) + "Return the value associated with KEY in HASHTABLE. +If the optional argument IGNORE-CASE is given, then case in the key is +considered irrelevant." + (` (let* ((key (efs-make-hash-key (, key))) + (sym (if (, ignore-case) + (efs-case-fold-intern-soft key (, tbl)) + (intern-soft key (, tbl))))) + (and sym (get sym 'val))))) + +(defmacro efs-put-hash-entry (key val tbl &optional ignore-case) + "Record an association between KEY and VALUE in HASHTABLE. +If the optional IGNORE-CASE argument is given, then check for an entry +which is the same modulo case, and update it instead of adding a new entry." + (` (let* ((key (efs-make-hash-key (, key))) + (sym (if (, ignore-case) + (or (efs-case-fold-intern-soft key (, tbl)) + (intern key (, tbl))) + (intern key (, tbl))))) + (put sym 'val (, val))))) + +(defun efs-del-hash-entry (key tbl &optional ignore-case) + "Copy all symbols except KEY in HASHTABLE and return modified hashtable. +If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case." + (let* ((len (length tbl)) + (new-tbl (efs-make-hashtable len)) + (i (1- len)) + (key (efs-make-hash-key key))) + (if ignore-case (setq key (downcase key))) + (efs-map-hashtable + (if ignore-case + (function + (lambda (k v) + (or (string-equal (downcase k) key) + ;; Don't need to specify ignore-case here, because + ;; we have already weeded out possible case-fold matches. + (efs-put-hash-entry k v new-tbl)))) + (function + (lambda (k v) + (or (string-equal k key) + (efs-put-hash-entry k v new-tbl))))) + tbl) + (while (>= i 0) + (aset tbl i (aref new-tbl i)) + (setq i (1- i))) + ;; Return the result. + tbl)) + +(defun efs-hash-table-keys (tbl &optional nosort) + "Return a sorted of all the keys in the hashtable TBL, as strings. +This list is sorted, unless the optional argument NOSORT is non-nil." + (let ((result (all-completions "" tbl))) + (if nosort + result + (sort result (function string-lessp))))) + +;;; hashtable variables + +(defconst efs-host-hashtable (efs-make-hashtable) + "Hash table holding data on hosts.") + +(defconst efs-host-user-hashtable (efs-make-hashtable) + "Hash table for holding data on host user pairs.") + +(defconst efs-minidisk-hashtable (efs-make-hashtable) + "Mapping between a host, user, minidisk triplet and a account password.") + +;;;; ------------------------------------------------------------ +;;;; Host / User mapping +;;;; ------------------------------------------------------------ + +(defun efs-set-host-property (host property value) + ;; For HOST, sets PROPERTY to VALUE. + (put (intern (downcase host) efs-host-hashtable) property value)) + +(defun efs-get-host-property (host property) + ;; For HOST, gets PROPERTY. + (get (intern (downcase host) efs-host-hashtable) property)) + +(defun efs-set-host-user-property (host user property value) + ;; For HOST and USER, sets PROPERTY to VALUE. + (let* ((key (concat (downcase host) "/" user)) + (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) + (efs-case-fold-intern-soft key efs-host-user-hashtable)))) + (or sym (setq sym (intern key efs-host-user-hashtable))) + (put sym property value))) + +(defun efs-get-host-user-property (host user property) + ;; For HOST and USER, gets PROPERTY. + (let* ((key (concat (downcase host) "/" user)) + (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) + (efs-case-fold-intern-soft key efs-host-user-hashtable)))) + (or sym (setq sym (intern key efs-host-user-hashtable))) + (get sym property))) + +(defun efs-set-user (host user) + "For a given HOST, set or change the default USER." + (interactive "sHost: \nsUser: ") + (efs-set-host-property host 'user user)) + +;;;; ------------------------------------------------------------ +;;;; Encryption +;;;; ------------------------------------------------------------ + +(defconst efs-passwd-seed nil) +;; seed used to encrypt the password cache. + +(defun efs-get-passwd-seed () + ;; Returns a random number to use for encrypting passwords. + (or efs-passwd-seed + (setq efs-passwd-seed (+ 1 (random 255))))) + +(defun efs-code-string (string) + ;; Encode a string, using `efs-passwd-seed'. This is nil-potent, + ;; meaning applying it twice decodes. + (if (and (fboundp 'int-char) (fboundp 'char-int)) + (mapconcat + (function + (lambda (c) + (char-to-string + (int-char (logxor (efs-get-passwd-seed) (char-int c)))))) + string "") + (mapconcat + (function + (lambda (c) + (char-to-string (logxor (efs-get-passwd-seed) c)))) + string ""))) + +;;; end of efs-cu.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-defun.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-defun.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,393 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-defun.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs-defun allows for OS-dependent coding of functions +;; Author: Sandy Rutherford +;; Created: Thu Oct 22 17:58:14 1992 +;; Modified: Sun Nov 27 12:18:35 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; efs-defun allows object-oriented emacs lisp definitions. +;;; In efs, this feature is used to support multiple host types. +;;; +;;; The first arg after the function name is a key which determines +;;; which version of the function is being defined. Normally, when the function +;;; is called this key is given as the first argument to the function. +;;; +;;; For example: +;;; +;;; (efs-defun foobar vms (x y) +;;; (message "hello vms world") +;;; (+ x y)) +;;; => foobar +;;; +;;; (foobar 'vms 1 2) +;;; => 3 + +;;; The key nil plays a special role: +;;; +;;; First, it defines a default action. If there is no function +;;; definition associated with a given OS-key, then the function +;;; definition associated with nil is used. If further there is no +;;; function definition associated with nil, then an error is +;;; signaled. +;;; +;;; Second, the documentation string for the function is the one given +;;; with the nil definition. You can supply doc-strings with other +;;; definitions of the function, but they are not accessible with +;;; 'describe-function. In fact, when the function is either loaded or +;;; byte-compiled, they are just thrown away. + +;;; There is another way to define the default action of an efs-function. +;;; This is with the use flag. If you give as the key (&use foobar), +;;; then when the function is called the variable foobar will be used to +;;; determine which OS version of the function to use. As well as +;;; allowing you to define the doc string, if the use flag is used, +;;; then you can specify an interactive specification with the function. +;;; Although a function is only interactive, if the default definition +;;; has an interactive spec, it is still necessary to give interactive +;;; specs for the other definitions of the function as well. It is possible +;;; for these interactive specs to differ. +;;; +;;; For example: +;;; +;;; (efs-defun fizzle (&use foobar) +;;; "Fizzle's doc string." +;;; (interactive) +;;; (message "fizz wizz")) +;;; +;;; (efs-defun fizzle vms +;;; (interactive) +;;; (message "VMS is fizzled.")) +;;; +;;; (setq foobar 'unix) +;;; => unix +;;; +;;; (fizzle) +;;; => "fizz wizz" +;;; +;;; (setq foobar 'vms) +;;; => vms +;;; +;;; (fizzle) +;;; => "VMS is fizzled." +;;; +;;; M-x f i z z l e +;;; => "VMS is fizzled." +;;; +;;; Actually, when you use the &use spec, whatever follows it is simply +;;; evaluated at call time. + +;;; Note that when the function is defined, the key is implicitly +;;; quoted, whereas when the function is called, the key is +;;; evaluated. If this seems strange, think about how efs-defuns +;;; are used in practice. + +;;; There are no restrictions on the order in which the different OS-type +;;; definitions are done. + +;;; There are no restrictions on the keys that can be used, nor on the +;;; symbols that can be used as arguments to an efs-defun. We go +;;; to some lengths to avoid potential conflicts. In particular, when +;;; the OS-keys are looked up in the symbol's property list, we +;;; actually look for a symbol with the same name in the special +;;; obarray, efs-key-obarray. This avoids possible conflicts with +;;; other entries in the property list, that are usually accessed with +;;; symbols in the standard obarray. + +;;; The V19 byte-compiler will byte-compile efs-defun's. +;;; The standard emacs V18 compiler will not, however they will still +;;; work, just not at byte-compiled speed. + +;;; efs-autoload works much like the standard autoload, except it +;;; defines the efs function cell for a given host type as an autoload. +;;; The from-kbd arg only makes sense if the default action of the autoload +;;; has been defined with a &use. + +;;; To do: +;;; +;;; 1. Set an edebug-form-hook for efs-defun + +;;; Known Bugs: +;;; +;;; 1. efs-autoload will correctly NOT overload an existing function +;;; definition with an autoload definition. However, it will also +;;; not overload a previous autoload with a new one. It should. An +;;; overload can be forced for the KEY def of function FUN by doing +;;; (put 'FUN (intern "KEY" efs-key-obarray) nil) first. +;;; + +;;; Provisions and requirements + +(provide 'efs-defun) +(require 'backquote) + +;;; Variables + +(defconst efs-defun-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-key-obarray (make-vector 7 0)) + +;; Unfortunately, we need to track this in bytecomp.el. +;; It's not much to keep track of, although. +(defconst efs-defun-bytecomp-buffer "*Compile-Log*") + +(defvar efs-key nil + "Inside an efs function, this is set to the key that was used to +call the function. You can test this inside the default definition, to +determine which key was actually used.") +(defvar efs-args nil + "Inside an efs function, this is set to a list of the calling args +of the function.") + +;;; Utility Functions + +;;; These functions are called when the macros efs-defun and efs-autoload +;;; are expanded. Their purpose is to help in producing the expanded code. + +(defun efs-defun-arg-count (list) + ;; Takes a list of arguments, and returns a list of three + ;; integers giving the number of normal args, the number + ;; of &optional args, and the number of &rest args (this should + ;; only be 0 or 1, but we don't check this). + (let ((o-leng (length (memq '&optional list))) + (r-leng (length (memq '&rest list))) + (leng (length list))) + (list (- leng (max o-leng r-leng)) + (max 0 (- o-leng r-leng 1)) + (max 0 (1- r-leng))))) + +;; For each efs-function the property efs-function-arg-structure +;; is either a list of three integers to indicate the number of normal, +;; optional, and rest args, or it can be the symbol 'autoload to indicate +;; that all definitions of the function are autoloads, and we have no +;; idea of its arg structure. + +(defun efs-defun-arg-check (fun key list) + ;; Checks that the LIST of args is consistent for the KEY def + ;; of function FUN. + (let ((prop (get fun 'efs-function-arg-structure)) + count) + (if (eq list 'autoload) + (or prop (put fun 'efs-function-arg-structure 'autoload)) + (setq count (efs-defun-arg-count list)) + (if (and prop (not (eq prop 'autoload)) (not (equal prop count))) + (let ((warning + (format + "args. for the %s def. of %s don't agree with previous defs." + key fun))) + (message (concat "Warning: " warning)) + ;; We are compiling, I suppose... + (if (get-buffer efs-defun-bytecomp-buffer) + (save-excursion + (set-buffer efs-defun-bytecomp-buffer) + (goto-char (point-max)) + (insert "efs warning:\n " warning "\n"))))) + (put fun 'efs-function-arg-structure count)))) + +(defun efs-def-generic (fun use doc-string interactive-p) + ;; Generates a generic function def using USE. + ;; If use is nil, the first arg of the function + ;; is the key. + (let ((def-args '(&rest efs-args)) + result) + (or use + (setq def-args (cons 'efs-key def-args))) + (setq result + (` (or (get (quote (, fun)) + (, (if use + (list 'intern + (list 'symbol-name use) + 'efs-key-obarray) + '(intern + (symbol-name efs-key) + efs-key-obarray)))) + (get (quote (, fun)) + (intern "nil" efs-key-obarray))))) + ;; Make the gen fun interactive, if nec. + (setq result + (if interactive-p + (` ((interactive) + (if (interactive-p) + (let ((prefix-arg current-prefix-arg)) + (call-interactively + (, result))) + (, (cons 'apply (list result 'efs-args)))))) + (list (cons 'apply (list result 'efs-args))))) + (if doc-string (setq result (cons doc-string result))) + (cons 'defun (cons fun (cons def-args result))))) + +(defun efs-def-autoload (fun key file from-kbd) + ;; Returns the autoload lambda for FUN and FILE. + ;; I really should have some notion of efs-autoload + ;; objects, and not just plain lambda's. + (let ((result + (if from-kbd + (` + (lambda (&rest args) + (interactive) + (let ((qkey (intern (symbol-name (quote (, key))) + efs-key-obarray)) + (tmp1 (intern "tmp1" efs-key-obarray)) + (tmp2 (intern "tmp2" efs-key-obarray))) + ;; Need to store the a-f-function, to see if it has been + ;; re-defined by the load. This is avoid to an infinite loop. + (set tmp1 (get (quote (, fun)) qkey)) + ;; Need to store the prefix arg in case it's interactive. + ;; These values are stored in variables interned in the + ;; efs-key-obarray, because who knows what loading a + ;; file might do. + (set tmp2 current-prefix-arg) + (load (, file)) + ;; check for re-def + (if (equal (symbol-value tmp1) + (get (quote (, fun)) qkey)) + (error "%s definition of %s is not defined by loading %s" + qkey (quote (, fun)) (, file))) + ;; call function + (if (interactive-p) + (let ((prefix-arg (symbol-value tmp2))) + (call-interactively + (get (quote (, fun)) qkey))) + (apply (get (quote (, fun)) qkey) args))))) + (` (lambda (&rest args) + (let ((qkey (intern (symbol-name (quote (, key))) + efs-key-obarray)) + (tmp1 (intern "tmp1" efs-key-obarray))) + ;; Need to store the a-f-function, to see if it has been + ;; re-defined by the load. This is avoid to an infinite loop. + (set tmp1 (get (quote (, fun)) qkey)) + (load (, file)) + ;; check for re-def + (if (equal (symbol-value tmp1) + (get (quote (, fun)) qkey)) + (error "%s definition of %s is not defined by loading %s" + qkey (quote (, fun)) (, file))) + ;; call function + (apply (get (quote (, fun)) qkey) args))))))) + (list 'put (list 'quote fun) + (list 'intern + (list 'symbol-name (list 'quote key)) + 'efs-key-obarray) + (list 'function result)))) + +;;; User level macros -- efs-defun and efs-autoload. + +(defmacro efs-defun (funame key args &rest body) + (let* ((use (and (eq (car-safe key) '&use) + (nth 1 key))) + (key (and (null use) key)) + result doc-string interactive-p) + ;; check args + (efs-defun-arg-check funame key args) + ;; extract doc-string + (if (stringp (car body)) + (setq doc-string (car body) + body (cdr body))) + ;; If the default fun is interactive, and it's a use construct, + ;; then we allow the gen fun to be interactive. + (if use + (setq interactive-p (eq (car-safe (car-safe body)) 'interactive))) + (setq result + (` ((put (quote (, funame)) + (intern (symbol-name (quote (, key))) + efs-key-obarray) + (function + (, (cons 'lambda + (cons args body))))) + (quote (, funame))))) + ;; if the key is null, make a generic def + (if (null key) + (setq result + (cons (efs-def-generic + funame use doc-string interactive-p) + result))) + ;; return + (cons 'progn result))) + +;;; For lisp-mode + +(put 'efs-defun 'lisp-indent-hook 'defun) + +;; efs-autoload +;; Allows efs function cells to be defined as autoloads. +;; If efs-autoload inserted autoload objects in the property list, +;; and the funcall mechanism in efs-defun checked for such +;; auto-load objects, we could reduce the size of the code +;; resulting from expanding efs-autoload. However, the expansion +;; of efs-defun would be larger. What is the best thing to do? + +(defmacro efs-autoload (fun key file &optional docstring from-kbd) + (let* ((use (and (eq (car-safe key) '&use) + (nth 1 key))) + (key (and (null use) key))) + (efs-defun-arg-check (eval fun) key 'autoload) + ;; has the function been previously defined? + (` + (if (null (get (, fun) + (intern (symbol-name (quote (, key))) + efs-key-obarray))) + (, + (if (null key) + (list 'progn + ;; need to eval fun, since autoload wants an explicit + ;; quote built into the fun arg. + (efs-def-generic + (eval fun) use docstring from-kbd ) + (efs-def-autoload (eval fun) key file from-kbd) + (list 'quote + (list + 'efs-autoload + key file docstring from-kbd))) + (list 'progn + (efs-def-autoload (eval fun) key file from-kbd) + (list 'quote + (list + 'efs-autoload + key file docstring from-kbd))))))))) + +(defun efs-fset (sym key fun) + ;; Like fset but sets KEY's definition of SYM. + (put sym (intern (symbol-name key) efs-key-obarray) fun)) + +(defun efs-fboundp (key fun) + ;; Like fboundp, but checks for KEY's def. + (null (null (get fun (intern (symbol-name key) efs-key-obarray))))) + +;; If we are going to use autoload objects, the following two functions +;; will be useful. +;; +;; (defun efs-defun-do-autoload (fun file key interactive-p args) +;; ;; Loads FILE and runs the KEY def of FUN. +;; (let (fun file key interactive-p args) +;; (load file)) +;; (let ((new-def (get fun key))) +;; (if (eq (car-safe new-def) 'autoload) +;; (error "%s definition of %s is not defined by loading %s" +;; key fun file) +;; (if interactive-p +;; (let ((prefix-arg current-predix-arg)) +;; (call-interactively fun)) +;; (apply new-def args))))) +;; +;; (defun efs-defun-autoload (fun key file doc-string from-kbd) +;; ;; Sets the KEY def of FUN to an autoload object. +;; (let* ((key (intern (symbol-name key) efs-key-obarray)) +;; (def (get fun key))) +;; (if (or (null def) +;; (eq (car-safe def) 'autoload)) +;; (put fun key (list 'autoload file doc-string from-kbd))))) + +;;; end of efs-defun.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-dired-mule.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dired-mule.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,55 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dired.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Makes efs-dired.el work with MULE. +;; Author: Ishikawa Ichiro +;; Created: Sat Aug 20 05:25:55 1994 +;; Modified: Sun Nov 27 12:19:17 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst efs-dired-mule-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; Keep the byte-compiler happy +(defvar efs-version-host-types) +(defvar efs-dired-host-type) + +(defun efs-dired-find-file (&optional coding-system) + "Documented as original" + (interactive "ZCoding-system: ") + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file file coding-system))) + +(defun efs-dired-find-file-other-window (&optional display coding-system) + "Documented as original" + (interactive "P\nZCoding-system: ") + (if display + (dired-display-file coding-system) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file-other-window file coding-system)))) + + +(defun efs-dired-display-file (&optional coding-system) + "Documented as original" + (interactive "ZCoding-system: ") + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (display-buffer (find-file-noselect file coding-system)))) + +;;; end of efs-dired-mule.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dired.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,1645 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dired.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Extends much of Dired to work under efs. +;; Authors: Sebastian Kremer , +;; Andy Norman , +;; Sandy Rutherford +;; Created: Throughout the ages. +;; Modified: Sun Nov 27 12:19:46 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Provisions and requirements + +(provide 'efs-dired) +(require 'efs) +(require 'dired) +(autoload 'dired-shell-call-process "dired-shell") + +(defconst efs-dired-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.2 $" 11 -2))) + +;;;; ---------------------------------------------------------------- +;;;; User Configuration Variables +;;;; ---------------------------------------------------------------- + +(defvar efs-dired-verify-modtime-host-regexp nil + "Regular expression determining on which hosts dired modtimes are checked.") + +(defvar efs-dired-verify-anonymous-modtime nil + "If non-nil, dired modtimes are checked for anonymous logins.") + +(defvar efs-remote-shell-file-name + (if (memq system-type '(hpux usg-unix-v)) ; hope that's right + "remsh" + "rsh") + "Remote shell used by efs.") + +(defvar efs-remote-shell-takes-user + (null (null (memq system-type '(aix-v3 hpux silicon-graphics-unix + berkeley-unix)))) + ;; Complete? Doubt it. + "Set to non-nil if your remote shell command takes \"-l USER\".") + +;;; Internal Variables + +(make-variable-buffer-local 'dired-ls-F-marks-symlinks) + +;;;; ----------------------------------------------------------- +;;;; Inserting Directories into Buffers +;;;; ----------------------------------------------------------- + +;; The main command for inserting a directory listing in a buffer. +;; In Emacs 19 this is in files.el, and not specifically connected to +;; dired. Since our version of it uses some dired functions, it is +;; included here, but there is an autoload for it in efs.el. + +(defun efs-insert-directory (file switches &optional wildcard full-directory-p + nowait marker-char) + ;; Inserts a remote directory. Can do this asynch. + (let* ((parsed (efs-ftp-path file)) + (mk (point-marker)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (host-type (efs-host-type host)) + (dumb (memq host-type efs-dumb-host-types)) + (subdir (and (null (or full-directory-p wildcard)) + (condition-case nil + (dired-current-directory) + (error nil)))) + (case-fold-search nil) ; for testing switches + (parse (and full-directory-p (not wildcard) + (or dumb (efs-parsable-switches-p switches)))) + ;; In case dired-omit-silent isn't defined. + (dired-omit-silent (and (boundp 'dired-omit-silent) + dired-omit-silent))) + + ;; Insert the listing. If it's not a wild-card, and not a full-dir, + ;; then we are updating a dired-line. Do this asynch. + ;; This way of doing the listing makes sure that the dired + ;; buffer is still around after the listing is obtained. + + (efs-ls + file switches t (if parse 'parse t) nil + ;; asynch, if we're inserting in a subdir. Do it nowait = 0, so + ;; updating the file line gets a high priority?? + ;; Insert subdir listings NOWAIT = 0 also so 1-line + ;; updates don't toggle the mode line. + (if (and subdir nowait) 0 nowait) + (efs-cont (listing) (host user file path wildcard + nowait marker-char + mk subdir parse switches dired-omit-silent) + ;; We pass the value of dired-omit-silent from the caller to the cont. + (let ((host-type (efs-host-type host)) + (listing-type (efs-listing-type host user))) + (if (marker-buffer mk) + (efs-save-buffer-excursion + (set-buffer (marker-buffer mk)) + ;; parsing a listing, sometimes updates info + (if (and parse (eq major-mode 'dired-mode)) + (progn + (setq efs-dired-host-type host-type + efs-dired-listing-type listing-type + efs-dired-listing-type-string + (and efs-show-host-type-in-dired + (concat " " + (symbol-name + efs-dired-listing-type)))) + (if (memq host-type '(bsd-unix next-unix)) + (setq dired-ls-F-marks-symlinks nil) + (if (memq host-type '(sysV-unix apollo-unix)) + (setq dired-ls-F-marks-symlinks t))))) + (if subdir + ;; a 1-line re-list + (save-excursion + (efs-update-file-info + host-type file efs-data-buffer-name) + (goto-char mk) + (let ((new-subdir (condition-case nil + (dired-current-directory) + (error nil))) + buffer-read-only) + (if (and new-subdir + (string-equal subdir new-subdir)) + (progn + ;; Is there an existing entry? + (if (dired-goto-file file) + (progn + (delete-region + (save-excursion + (skip-chars-backward "^\n\r") + (1- (point))) + (progn + (skip-chars-forward "^\n\r") + (point))) + (goto-char mk))) + (insert listing) + (save-restriction + (narrow-to-region mk (point)) + (efs-dired-fixup-listing + listing-type file path switches wildcard) + (efs-dired-ls-trim + listing-type) + ;; save-excursion loses if fixup had to + ;; remove and re-add the region. Say for + ;; sorting. + (goto-char (point-max))) + (if (and nowait (eq major-mode 'dired-mode)) + (dired-after-add-entry + (marker-position mk) + marker-char)))))) + (goto-char mk) + (let (buffer-read-only) + (insert listing) + (save-restriction + (narrow-to-region mk (point)) + (efs-dired-fixup-listing + listing-type file path switches wildcard) + (goto-char (point-max)))))))))) + ;; Return 0 if synch, nil if asynch + (if nowait nil 0))) + +;;; Functions for cleaning listings. + +(efs-defun efs-dired-ls-trim nil () + ;; Trims dir listings, so that the listing of a single file is one line. + nil) + +(efs-defun efs-dired-fixup-listing nil (file path &optional switches wildcard) + ;; FILE is in efs syntax. + ;; PATH is just the remote path. + ;; Some ftpd's put the whole directory name in front of each filename. + ;; Seems to depend in a strange way on server-client interaction. + ;; Walk down the listing generated and remove this stuff. + ;; SWITCHES is a string. + (if (memq efs-key efs-unix-host-types) + (let ((continue t) + spot bol) + (goto-char (point-min)) + (while (and (not (eobp)) continue) + (and (setq bol (point) + spot (dired-manual-move-to-filename nil bol)) + (setq continue (= (following-char) ?/)) + (dired-manual-move-to-end-of-filename t bol) + (progn + (skip-chars-backward "^/") + (delete-region spot (point)))) + (forward-line 1)) + (efs-save-match-data + (if (and switches (string-match "R" switches) + (not (string-match "d" switches))) + (let ((subdir-regexp "^\\(/[^ \n\r]+\\):[\n\r]") + name) + (goto-char (point-min)) + (while (re-search-forward subdir-regexp nil t) + (goto-char (match-beginning 0)) + ;; There may be /./ type nonsense. + ;; expand-file-name will handle it. + (setq name (expand-file-name + (buffer-substring (point) (match-end 0)))) + (delete-region (point) (match-end 0)) + (insert (efs-replace-path-component file name))))))))) + + +;;;; ------------------------------------------------------------ +;;;; Tree Dired support +;;;; ------------------------------------------------------------ + +;;; efs-dired keymap + +(defvar efs-dired-map nil + "Keymap for efs commands in dired buffers.") + +(if efs-dired-map + () + (setq efs-dired-map (make-sparse-keymap)) + (define-key efs-dired-map "c" 'efs-dired-close-ftp-process) + (define-key efs-dired-map "k" 'efs-dired-kill-ftp-process) + (define-key efs-dired-map "o" 'efs-dired-display-ftp-process-buffer) + (define-key efs-dired-map "p" 'efs-dired-ping-connection)) + +(fset 'efs-dired-prefix efs-dired-map) + +;;; Functions for dealing with the FTP process + +(defun efs-dired-close-ftp-process () + "Close the FTP process for the current dired buffer. +Closing causes the connection to be dropped, but efs will retain its +cached data for the connection. This will make it more efficient to +reopen the connection." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-close-ftp-process (current-buffer)) + (let ((parsed (efs-ftp-path default-directory))) + (message "Closed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) + +(defun efs-dired-kill-ftp-process () + "Kills the FTP process for the current dired buffer. +Killing causes the connection to be closed, the process buffer to be killed, +and most of efs's cached data to be wiped." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-kill-ftp-process (current-buffer)) + (let ((parsed (efs-ftp-path default-directory))) + (message "Killed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) + +(defun efs-dired-display-ftp-process-buffer () + "Displays in another window the FTP process buffer for a dired buffer." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-display-ftp-process-buffer (current-buffer))) + +(defun efs-dired-ping-connection () + "Pings FTP connection associated with current dired buffer." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-ping-ftp-connection (current-buffer))) + + +;;; Reading in dired buffers. + +(defun efs-dired-revert (&optional arg noconfirm) + (let ((efs-ls-uncache t)) + (dired-revert arg noconfirm))) + +(defun efs-dired-default-dir-function () + (let* ((cd (dired-current-directory)) + (parsed (efs-ftp-path cd))) + (if parsed + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) cd) + (setq cd (concat (cdr (car tail)) + (substring cd (match-end 0))) + parsed nil)) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename + (or parsed (efs-ftp-path cd))))) + cd))) + +(defun efs-dired-before-readin () + ;; Put in the dired-before-readin-hook. + (let ((parsed (efs-ftp-path default-directory))) + (if parsed + (let ((host (car parsed)) + (user (nth 1 parsed))) + (setq efs-dired-listing-type (efs-listing-type host user) + efs-dired-host-type (efs-host-type host) + efs-dired-listing-type-string + (and efs-show-host-type-in-dired + (concat " " (symbol-name efs-dired-listing-type)))) + (set (make-local-variable 'revert-buffer-function) + (function efs-dired-revert)) + (set (make-local-variable 'default-directory-function) + (function efs-dired-default-dir-function)) + (set (make-local-variable 'dired-verify-modtimes) + (null (null (and + efs-dired-verify-modtime-host-regexp + (efs-save-match-data + (let ((case-fold-search t)) + (string-match + efs-dired-verify-modtime-host-regexp host)) + (or efs-dired-verify-anonymous-modtime + (not (efs-anonymous-p user)))))))) + ;; The hellsoft ftp server mixes up cases. + ;; However, we may not be able to catch this until + ;; after the first directory is listed. + (if (and + (eq efs-dired-host-type 'hell) + (not (string-equal default-directory + (setq default-directory + (downcase default-directory))))) + (or (string-equal (buffer-name) (downcase (buffer-name))) + (rename-buffer (generate-new-buffer-name + (directory-file-name default-directory))))) + ;; Setup the executable and directory regexps + (let ((eentry (assq efs-dired-listing-type + efs-dired-re-exe-alist)) + (dentry (assq efs-dired-listing-type + efs-dired-re-dir-alist))) + (if eentry + (set (make-local-variable 'dired-re-exe) (cdr eentry))) + (if dentry + (set (make-local-variable 'dired-re-dir) (cdr dentry)))) + ;; No switches are sent to dumb hosts, so don't confuse dired. + ;; I hope that dired doesn't get excited if it doesn't see the l + ;; switch. If it does, then maybe fake things by setting this to + ;; "-Al". + (if (eq efs-dired-listing-type 'vms) + (setq dired-internal-switches + (delq ?F dired-internal-switches)) + (if (memq efs-dired-host-type efs-dumb-host-types) + (setq dired-internal-switches '(?l ?A) + ;; Don't lie on the mode line + dired-sort-mode ""))) + ;; If the remote file system is version-based, don't set + ;; dired-kept-versions to 0. It will flag the most recent + ;; copy of the file for deletion -- this isn't really a backup. + (if (memq efs-dired-host-type efs-version-host-types) + (set (make-local-variable 'dired-kept-versions) + (max 1 dired-kept-versions))))))) + +(efs-defun efs-dired-insert-headerline (&use efs-dired-listing-type) (dir) + "Documented as original." + (efs-real-dired-insert-headerline dir)) + +(defun efs-dired-uncache (file dir-p) + ;; Remove FILE from cache. + (if dir-p + (efs-del-from-ls-cache file nil t) + (efs-del-from-ls-cache file t nil))) + +;;; Checking modtimes of directories. +;; +;; This only runs if efs-dired-verify-anonymous-modtime and +;; efs-verify-modtime-host-regexp turn it on. Few (any?) FTP servers +;; support getting MDTM for directories. As usual, we cache whether +;; this works, and don't keep senselessly trying it if it doesn't. + +(defun efs-dired-file-modtime (file) + ;; Returns the modtime. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (rpath (nth 2 parsed))) + (and (null (efs-get-host-property host 'dir-mdtm-failed)) + (let ((result (efs-send-cmd host user (list 'quote 'mdtm rpath) + (and (eq efs-verbose t) + "Getting modtime"))) + mp) + (if (and (null (car result)) + (setq mp (efs-parse-mdtime (nth 1 result)))) + (let ((ent (efs-get-file-entry file))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) mp))) + parsed) + (efs-set-host-property host 'dir-mdtm-failed t) + nil))))) + +(defun efs-dired-set-file-modtime (file alist) + ;; This works asynch. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed))) + (if (efs-get-host-property host 'dir-mdtm-failed) + (let ((elt (assoc file alist))) + (if elt (setcar (nthcdr 4 elt) nil))) + (efs-send-cmd + host user (list 'quote 'mdtm path) nil nil + (efs-cont (result line cont-lines) (file alist host) + (let ((elt (assoc file alist)) + modtime) + (if (and (null result) (setq modtime (efs-parse-mdtime line))) + (if elt (setcar (nthcdr 4 elt) modtime)) + (if elt (setcar (nthcdr 4 elt) nil)) + (efs-set-host-property host 'dir-mdtm-failed t)))) + 0) ; Always do this NOWAIT = 0 + nil))) ; return NIL + +;;; Asynch insertion of subdirs. Used when renaming subdirs. + +(defun efs-dired-insert-subdir (dirname &optional noerror nowait) + (let ((buff (current-buffer)) + (switches (delq ?R (copy-sequence dired-internal-switches)))) + (efs-ls + dirname (dired-make-switches-string switches) + t nil noerror nowait + (efs-cont (listing) (dirname buff switches) + (if (and listing (get-buffer buff)) + (save-excursion + (set-buffer buff) + (save-excursion + (let ((elt (assoc dirname dired-subdir-alist)) + mark-list) + (if elt + (setq mark-list (dired-insert-subdir-del elt)) + (dired-insert-subdir-newpos dirname)) + (dired-insert-subdir-doupdate + dirname + (efs-dired-insert-subdir-do-insert dirname listing) + switches elt mark-list))))))))) + +(defun efs-dired-insert-subdir-do-insert (dirname listing) + (let ((begin (point)) + indent-tabs-mode end) + (insert listing) + (setq end (point-marker)) + (indent-rigidly begin end 2) + (goto-char begin) + (dired-insert-headerline dirname) + ;; If the listing has null lines `quote' them so that "\n\n" delimits + ;; subdirs. This is OK, because we aren't inserting -R listings. + (save-excursion + (while (search-forward "\n\n" end t) + (forward-char -1) + (insert " "))) + ;; point is now like in dired-build-subdir-alist + (prog1 + (list begin (marker-position end)) + (set-marker end nil)))) + +;;; Moving around in dired buffers. + +(efs-defun efs-dired-manual-move-to-filename (&use efs-dired-listing-type) + (&optional raise-error bol eol) + "Documented as original." + (efs-real-dired-manual-move-to-filename raise-error bol eol)) + +(efs-defun efs-dired-manual-move-to-end-of-filename + (&use efs-dired-listing-type) (&optional no-error bol eol) + "Documented as original." + (efs-real-dired-manual-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-make-filename-string (&use efs-dired-listing-type) + (filename &optional reverse) + "Documented as original." + ;; This translates file names from the way that they are displayed + ;; in listings to the way that the user gives them in the minibuffer. + ;; For example, in CMS this should take "FOO BAR" to "FOO.BAR". + filename) + +(defun efs-dired-find-file () + "Documented as original." + (interactive) + (find-file + (if (memq efs-dired-host-type efs-version-host-types) + (efs-internal-file-name-sans-versions + efs-dired-host-type (dired-get-filename) t) + (dired-get-filename)))) + +(defun efs-dired-find-file-other-window (&optional display) + "Documented as original." + (interactive "P") + (if display + (dired-display-file) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file-other-window file)))) + +(defun efs-dired-display-file () + "Documented as original." + (interactive) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (display-buffer (find-file-noselect file)))) + +(defun efs-dired-find-file-other-frame () + "Documented as original." + (interactive) + (find-file-other-frame + (if (memq efs-dired-host-type efs-version-host-types) + (efs-internal-file-name-sans-versions + efs-dired-host-type (dired-get-filename) t) + (dired-get-filename)))) + +;;; Creating and deleting new directories. + +(defun efs-dired-recursive-delete-directory (fn) + ;; Does recursive deletion of remote directories for dired. + (or (file-exists-p fn) + (signal 'file-error + (list "Removing old file name" "no such directory" fn))) + (efs-dired-internal-recursive-delete-directory fn)) + +(defun efs-dired-internal-recursive-delete-directory (fn) + (if (eq (car (file-attributes fn)) t) + (let ((files (efs-directory-files fn))) + (if files + (mapcar (function + (lambda (ent) + (or (string-equal "." ent) + (string-equal ".." ent) + (efs-dired-internal-recursive-delete-directory + (expand-file-name ent fn))))) + files)) + (efs-delete-directory fn)) + (condition-case err + (efs-delete-file fn) + (ftp-error (if (and (nth 2 err) (stringp (nth 2 err)) + (efs-save-match-data + (string-match "^FTP Error: \"550 " (nth 2 err)))) + (message "File %s already deleted." fn) + (signal (car err) (cdr err))))))) + +;;; File backups and versions. + +(efs-defun efs-dired-flag-backup-files + (&use efs-dired-host-type) (&optional unflag-p) + "Documented as original." + (interactive "P") + (efs-real-dired-flag-backup-files unflag-p)) + +(efs-defun efs-dired-collect-file-versions (&use efs-dired-host-type) () + ;; If it looks like a file has versions, return a list of the versions. + ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) + (efs-real-dired-collect-file-versions)) + +;;; Sorting dired buffers + +(defun efs-dired-file-name-lessp (name1 name2) + (if (and efs-dired-host-type + (memq efs-dired-host-type efs-case-insensitive-host-types)) + (string< (downcase name1) (downcase name2)) + (string< name1 name2))) + +;;; Support for async file creators. + +(defun efs-dired-copy-file (from to ok-flag &optional cont nowait) + ;; Version of dired-copy-file for remote files. + ;; Assumes that filenames are already expanded. + (dired-handle-overwrite to) + (efs-copy-file-internal from (efs-ftp-path from) to (efs-ftp-path to) + ok-flag dired-copy-preserve-time 0 cont nowait)) + +(defun efs-dired-rename-file (from to ok-flag &optional cont nowait + insert-subdir) + ;; Version of dired-rename-file for remote files. + (dired-handle-overwrite to) + (efs-rename-file-internal + from to ok-flag nil + (efs-cont (result line cont-lines) (from to cont insert-subdir) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Dired Renaming" + (format "FTP Error: \"%s\"" line) + from to))) + (dired-remove-file from) + ;; Silently rename the visited file of any buffer visiting this file. + ;; We do not maintain inserted subdirs for remote + (efs-dired-rename-update-buffers from to insert-subdir) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait)) + +(defun efs-dired-rename-update-buffers (from to &optional insert-subdir) + (if (get-file-buffer from) + (save-excursion + (set-buffer (get-file-buffer from)) + (let ((modflag (buffer-modified-p))) + (set-visited-file-name to) ; kills write-file-hooks + (set-buffer-modified-p modflag))) + ;; It's a directory. More work to do. + (let ((blist (buffer-list)) + (from-dir (file-name-as-directory from)) + (to-dir (file-name-as-directory to))) + (save-excursion + (while blist + (set-buffer (car blist)) + (setq blist (cdr blist)) + (cond + (buffer-file-name + (if (dired-in-this-tree buffer-file-name from-dir) + (let ((modflag (buffer-modified-p))) + (unwind-protect + (set-visited-file-name + (concat to-dir (substring buffer-file-name + (length from-dir)))) + (set-buffer-modified-p modflag))))) + (dired-directory + (if (string-equal from-dir (expand-file-name default-directory)) + ;; If top level directory was renamed, lots of things + ;; have to be updated. + (progn + (dired-unadvertise from-dir) + (setq default-directory to-dir + dired-directory + ;; Need to beware of wildcards. + (expand-file-name + (file-name-nondirectory dired-directory) + to-dir)) + (let ((new-name (file-name-nondirectory + (directory-file-name dired-directory)))) + ;; Try to rename buffer, but just leave old name if new + ;; name would already exist (don't try appending "<%d>") + ;; Why? --sandy 19-8-94 + (or (get-buffer new-name) + (rename-buffer new-name))) + (dired-advertise)) + (and insert-subdir + (assoc (file-name-directory (directory-file-name to)) + dired-subdir-alist) + (if (efs-ftp-path to) + (efs-dired-insert-subdir to t 1) + (dired-insert-subdir to))))))))))) + +(defun efs-dired-make-relative-symlink (from to ok-flag &optional cont nowait) + ;; efs version of dired-make-relative-symlink + ;; Called as a file-name-handler when dired-make-relative-symlink is + ;; called interactively. + ;; efs-dired-create-files calls it directly to supply CONT + ;; and NOWAIT args. + (setq from (directory-file-name from) + to (directory-file-name to)) + (efs-make-symbolic-link-internal + (dired-make-relative from (file-name-directory to) t) + to ok-flag cont nowait)) + +(defun efs-dired-create-files (file-creator operation fn-list name-constructor + &optional marker-char query + implicit-to) + "Documented as original." + (if (catch 'found + (let ((list fn-list) + val) + (while list + (if (setq val (efs-ftp-path (car list))) + (throw 'found val) + (if (setq val (funcall name-constructor (car list))) + (throw 'found (efs-ftp-path val)) + (setq list (cdr list))))))) + (progn + (cond ((eq file-creator 'dired-copy-file) + (setq file-creator 'efs-dired-copy-file)) + ((eq file-creator 'dired-rename-file) + (setq file-creator 'efs-dired-rename-file)) + ((eq file-creator 'make-symbolic-link) + (setq file-creator 'efs-make-symbolic-link-internal)) + ((eq file-creator 'add-name-to-file) + (setq file-creator 'efs-add-name-to-file-internal)) + ((eq file-creator 'dired-make-relative-symlink) + (setq file-creator 'efs-dired-make-relative-symlink)) + ((eq file-creator 'dired-compress-file) + (setq file-creator 'efs-dired-compress-file)) + ((error "Unable to perform operation %s on remote hosts." + file-creator))) + ;; use the process-filter driven routine rather than the iterative one. + (efs-dcf-1 file-creator operation fn-list name-constructor + (if (eq marker-char t) + (mapcar 'dired-file-marker fn-list) + marker-char) + query (buffer-name (current-buffer)) + nil ;overwrite-query + nil ;dired-overwrite-backup-query + nil ;dired-file-creator-query + nil ;failures + nil ;skipped + 0 ;success-count + (length fn-list) ;total + implicit-to + (and (eq file-creator 'efs-dired-rename-file) + (delq nil + (mapcar + (function + (lambda (x) + (and (assoc (file-name-as-directory x) + dired-subdir-alist) + x))) + fn-list))))) + ;; normal case... use the interative routine... much cheaper. + (efs-real-dired-create-files file-creator operation fn-list + name-constructor marker-char query + implicit-to))) + +(defun efs-dcf-1 (file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + overwrite-backup-query file-creator-query + failures skipped success-count total + implicit-to insertions) + (if (null fn-list) + (efs-dcf-3 failures operation total skipped + success-count buffer-name) + (let* ((from (car fn-list)) + ;; For dired-handle-overwrite and the file-creator-query, + ;; need to set these 2 fluid vars according to the cont data. + (dired-overwrite-backup-query overwrite-backup-query) + (dired-file-creator-query file-creator-query) + (to (funcall name-constructor from)) + (marker-char (if (consp markers) + (prog1 (car markers) + (setq markers (cdr markers))) + markers)) + (fn-list (cdr fn-list))) + (if to + (if (equal to from) + (progn + (dired-log buffer-name "Cannot %s to same file: %s\n" + (downcase operation) from) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query + dired-file-creator-query failures + (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions)) + (if (or (null query) + (funcall query from to)) + (let* ((overwrite (let (jka-compr-enabled) + ;; Don't let jka-compr fool us. + (file-exists-p to))) + (overwrite-confirmed ; for dired-handle-overwrite + (and overwrite + (let ((help-form '(format "\ +Type SPC or `y' to overwrite file `%s', +DEL or `n' to skip to next, +ESC or `q' to not overwrite any of the remaining files, +`!' to overwrite all remaining files with no more questions." to))) + (dired-query 'overwrite-query + "Overwrite `%s'?" to))))) + (condition-case err + (let ((dired-unhandle-add-files + (cons to dired-unhandle-add-files))) + (if implicit-to + (funcall file-creator from overwrite-confirmed + (list (function efs-dcf-2) + file-creator operation fn-list + name-constructor markers + query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query + failures skipped success-count + total implicit-to insertions) + t) + (apply file-creator from to overwrite-confirmed + (list (function efs-dcf-2) + file-creator operation fn-list + name-constructor markers + query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query + failures skipped success-count total + implicit-to insertions) + (if insertions + (list t insertions) + '(t))))) + (error ; FILE-CREATOR aborted + (efs-dcf-2 'failed ;result + (format "%s" err) ;line + "" file-creator operation fn-list + name-constructor markers query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query failures skipped + success-count total implicit-to insertions)))) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query dired-file-creator-query + failures + (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions))) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query dired-file-creator-query + failures (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions))))) + +(defun efs-dcf-2 (result line cont-lines file-creator operation fn-list + name-constructor markers query marker-char + buffer-name to from overwrite overwrite-confirmed + overwrite-query overwrite-backup-query + file-creator-query failures skipped success-count + total implicit-to insertions) + (if result + (progn + (setq failures (cons (dired-make-relative from nil t) failures)) + (dired-log buffer-name "%s `%s' to `%s' failed:\n%s\n" + operation from to line)) + (setq success-count (1+ success-count)) + (message "%s: %d of %d" operation success-count total) + (let ((efs-ls-uncache t)) + (dired-add-file to marker-char))) + ;; iterate again + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query overwrite-backup-query + file-creator-query failures skipped success-count total + implicit-to insertions)) + +(defun efs-dcf-3 (failures operation total skipped success-count buffer-name) + (cond + (failures + (dired-log-summary buffer-name (format "%s failed for %d of %d file%s" + operation (length failures) total + (dired-plural-s total)) failures)) + (skipped + (dired-log-summary buffer-name (format "%s: %d of %d file%s skipped" + operation (length skipped) total + (dired-plural-s total)) skipped)) + (t + (message "%s: %s file%s." + operation success-count + (dired-plural-s success-count))))) + +;;; Running remote shell commands + +;;; This support isn't very good. efs is really about a virtual file system, +;;; and not remote processes. What is really required is low-level +;;; support for start-process & call-process on remote hosts. This shouldn't +;;; be part of efs, although. + +(defun efs-dired-shell-unhandle-file-name (filename) + ;; Puts remote file names into a form where they can be passed to remsh. + (nth 2 (efs-ftp-path filename))) + +(defun efs-dired-shell-call-process (command dir &optional in-background) + ;; Runs shell process on remote hosts. + (let* ((parsed (efs-ftp-path dir)) + (host (car parsed)) + (user (nth 1 parsed)) + (rdir (nth 2 parsed)) + (file-name-handler-alist nil)) + (or (string-equal (efs-internal-directory-file-name dir) + (efs-expand-tilde "~" (efs-host-type host) host user)) + (string-match "^cd " command) + (setq command (concat "cd " rdir "; " command))) + (setq command + (format "%s %s%s \"%s\"" ; remsh -l USER does not work well + ; on a hp-ux machine I tried + efs-remote-shell-file-name host + (if efs-remote-shell-takes-user + (concat " -l " user) + "") + command)) + (message "Doing shell command on %s..." host) + (dired-shell-call-process + command (file-name-directory efs-tmp-name-template) in-background))) + +;;; Dired commands for running local processes on remote files. +;; +;; Lots of things in this section need to be re-thunk. + +(defun efs-dired-call-process (program discard &rest arguments) + "Documented as original." + ;; PROGRAM is always one of those below in the cond in dired.el. + ;; The ARGUMENTS are (nearly) always files. + (if (efs-ftp-path default-directory) + ;; Can't use efs-dired-host-type here because the current + ;; buffer is *dired-check-process output* + (condition-case oops + (cond + ((string-equal "efs-call-compress" program) + (apply 'efs-call-compress arguments)) + ((string-equal "chmod" program) + (efs-call-chmod arguments)) + (t (error "Unknown remote command: %s" program))) + (ftp-error (dired-log (buffer-name (current-buffer)) + (format "%s: %s, %s\n" + (nth 1 oops) + (nth 2 oops) + (nth 3 oops)))) + (error (dired-log (buffer-name (current-buffer)) + (format "%s\n" (nth 1 oops))))) + (apply 'call-process program nil (not discard) nil arguments))) + +(defun efs-dired-make-compressed-filename (name &optional method) + ;; Version of dired-make-compressed-filename for efs. + ;; If NAME is in the syntax of a compressed file (according to + ;; dired-compression-method-alist), return the data (a list) from this + ;; alist on how to uncompress it. Otherwise, return a string, the + ;; uncompressed form of this file name. This is computed using the optional + ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of + ;; dired-compression-method is used. + (let* ((host-type (efs-host-type (car (efs-ftp-path name)))) + (ef-alist (if (memq host-type efs-single-extension-host-types) + (mapcar + (function + (lambda (elt) + (list (car elt) + (mapconcat + (function + (lambda (char) + (if (= char ?.) + "-" + (char-to-string char)))) + (nth 1 elt) "") + (nth 2 elt) + (nth 3 elt)))) + dired-compression-method-alist) + dired-compression-method-alist)) + (alist ef-alist) + (len (length name)) + ext ext-len result) + (if (memq host-type efs-version-host-types) + (setq name (efs-internal-file-name-sans-versions host-type name))) + (if (memq host-type efs-case-insensitive-host-types) + (let ((name (downcase name))) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal (downcase ext) + (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist))))) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal ext (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist))))) + (or result + (concat name + (nth 1 (or (assq (or method dired-compression-method) + ef-alist) + (error "Unknown compression method: %s" + (or method dired-compression-method)))))))) + +(defun efs-dired-compress-file (file ok-flag &optional cont nowait) + ;; Version of dired-compress-file for remote files. + (let* ((compressed-fn (efs-dired-make-compressed-filename file)) + (host (car (efs-ftp-path file))) + (host-type (efs-host-type host))) + (cond ((file-symlink-p file) + (if cont + (efs-call-cont + cont 'failed + (format "Cannot compress %s, a symbolic link." file) "") + (signal 'file-error (list "Compress error:" file + "a symbolic link")))) + ((listp compressed-fn) + (let ((newname (substring (if (memq host-type + efs-version-host-types) + (efs-internal-file-name-sans-versions + host-type file) + file) + 0 (- (length (nth 1 compressed-fn))))) + (program (nth 3 compressed-fn))) + (if (and (memq host-type efs-unix-host-types) + (null (efs-get-host-property host 'exec-failed)) + (null (eq (efs-get-host-property + host + (intern + (concat + "exec-" + (efs-compress-progname (car program))))) + 'failed))) + (efs-call-remote-compress + program file newname t ok-flag + (efs-cont (result line cont-lines) (program file newname + cont nowait) + (if result + (if (eq result 'unsupported) + (efs-call-compress program file newname + t t cont nowait) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Uncompressing file" + (format "FTP Error: \"%s\" " line) + file)))) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait) + (efs-call-compress + program file newname t ok-flag cont nowait) + newname))) + ((stringp compressed-fn) + (let ((program (nth 2 (assq dired-compression-method + dired-compression-method-alist)))) + (if (and (memq host-type efs-unix-host-types) + (null (efs-get-host-property host 'exec-failed)) + (null (eq (efs-get-host-property + host + (intern + (concat + "exec-" + (efs-compress-progname (car program))))) + 'failed))) + (efs-call-remote-compress + program file compressed-fn nil ok-flag + (efs-cont (result line cont-lines) (program file + compressed-fn + cont nowait) + (if result + (if (eq result 'unsupported) + (efs-call-compress program file compressed-fn nil + t cont nowait) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Compressing file" + (format "FTP Error: \"%s\" " line) + file)))) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait) + (efs-call-compress + program file compressed-fn nil ok-flag cont nowait))) + compressed-fn) + (t (error "Strange error in efs-dired-compress-file."))))) + +(defun efs-dired-print-file (command file) + ;; Version of dired-print-file for remote files. + (let ((command (dired-trans-command command (list file) ""))) + ;; Only replace the first occurence of the file name? + (if (string-match (concat "[ ><|]\\(" (regexp-quote + (dired-shell-quote file)) + "\\)\\($\\|[ |><&]\\)") + command) + (setq command (concat (substring command 0 (match-beginning 1)) + "%s" + (substring command (match-end 1)))) + (error "efs-print-command: strange error")) + (efs-call-lpr file command))) + +;;;;---------------------------------------------------------------- +;;;; Support for `processes' run on remote files. +;;;; Usually (but not necessarily) these are only called from dired. +;;;;---------------------------------------------------------------- + +(defun efs-compress-progname (program) + ;; Returns a canonicalized i.e. without the "un", version of a compress + ;; program name. + (efs-save-match-data + (if (string-equal program "gunzip") + "gzip" + (if (string-match "^un" program) + (substring program (match-end 0)) + program)))) + +(defun efs-call-remote-compress (program filename newname &optional uncompress + ok-if-already-exists cont nowait) + ;; Run a remote compress process using SITE EXEC. + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname + (if uncompress + "uncompress to it" + "compress to it") + (numberp ok-if-already-exists))) + (let* ((filename (expand-file-name filename)) + (parsed (efs-ftp-path filename)) + (host (car parsed)) + (user (nth 1 parsed)) + (rpath (nth 2 parsed))) + (if (efs-get-host-property host 'exec-failed) + (if cont + (efs-call-cont cont 'unsupported "SITE EXEC not supported" "") + (signal 'ftp-error (list "Unable to SITE EXEC" host))) + (let* ((progname (efs-compress-progname (car program))) + (propsym (intern (concat "exec-" progname))) + (prop (efs-get-host-property host propsym))) + (cond + ((eq prop 'failed) + (if cont + (efs-call-cont cont 'unsupported + (concat progname " not in FTP exec path") "") + (signal 'ftp-error + (list (concat progname " not in FTP exec path") host)))) + ((eq prop 'worked) + (efs-send-cmd + host user + (list 'quote 'site 'exec + (concat (mapconcat 'identity program " ") " " rpath)) + (concat (if uncompress "Uncompressing " "Compressing ") filename) + nil + (efs-cont (result line cont-lines) (host user filename cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (concat "FTP exec Error: " line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user (concat "FTP Error: " err)))) + ;; This function only gets called for unix hosts, so + ;; we'll use the default version of efs-delete-file-entry + ;; and save a host-type lookup. + (efs-delete-file-entry nil filename) + (dired-remove-file filename) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait)) + (t ; (null prop) + (efs-send-cmd + host user + (list 'quote 'site 'exec (concat progname " " "-V")) + (format "Checking for %s executable" progname) + nil + (efs-cont (result line cont-lines) (propsym host program filename + newname uncompress + cont nowait) + (efs-save-match-data + (if (string-match "\n200-" cont-lines) + (efs-set-host-property host propsym 'worked) + (efs-set-host-property host propsym 'failed))) + (efs-call-remote-compress program filename newname uncompress + t ; already tested for overwrite + cont nowait)) + nowait))))))) + +(defun efs-call-compress (program filename newname &optional uncompress + ok-if-already-exists cont nowait) + "Perform a compress command on a remote file. +PROGRAM is a list of the compression program and args. Works by taking a +copy of the file, compressing it and copying the file back. Returns 0 on +success, 1 or 2 on failure. If UNCOMPRESS is non-nil, does this instead." + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (parsed (efs-ftp-path filename)) + (tmp1 (car (efs-make-tmp-name nil (car parsed)))) + (tmp2 (car (efs-make-tmp-name nil (car parsed)))) + (program (mapconcat 'identity program " "))) + (efs-copy-file-internal + filename parsed tmp1 nil + t nil 2 + (efs-cont (result line cont-lines) (filename newname tmp1 tmp2 program + uncompress ok-if-already-exists + cont nowait) + (if result + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename)) + (let ((err-buff (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create + (generate-new-buffer-name + (format + " efs-call-compress %s" filename)))))) + (save-excursion + (set-buffer err-buff) + (set (make-local-variable 'efs-call-compress-filename) filename) + (set (make-local-variable 'efs-call-compress-newname) newname) + (set (make-local-variable 'efs-call-compress-tmp1) tmp1) + (set (make-local-variable 'efs-call-compress-tmp2) tmp2) + (set (make-local-variable 'efs-call-compress-cont) cont) + (set (make-local-variable 'efs-call-compress-nowait) nowait) + (set (make-local-variable 'efs-call-compress-ok) + ok-if-already-exists) + (set (make-local-variable 'efs-call-compress-uncompress) + uncompress) + (set (make-local-variable 'efs-call-compress-abbr) + (efs-relativize-filename filename)) + (if efs-verbose + (efs-message + (format "%s %s..." + (if uncompress "Uncompressing" "Compressing") + (symbol-value (make-local-variable + 'efs-call-compress-abbr))))) + (set-process-sentinel + (start-process (format "efs-call-compress %s" filename) + err-buff shell-file-name + "-c" (format "%s %s < %s > %s" + program + ;; Hope -c makes the compress + ;; program write to std out. + "-c" + tmp1 tmp2)) + (function + (lambda (proc str) + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (save-excursion + (set-buffer buff) + (if (/= (buffer-size) 0) + (if cont + (efs-call-cont + (symbol-value + (make-local-variable + 'efs-call-compress-cont)) + 'failed + (concat + "failed to compress " + (symbol-value (make-local-variable + 'efs-call-compress-filename)) + ", " + (buffer-substring + (point-min) + (progn (goto-char (point-min)) + (end-of-line) (point)))))) + (efs-del-tmp-name (symbol-value + (make-local-variable + 'efs-call-compress-tmp1))) + (let ((tmp2 (symbol-value + (make-local-variable + 'efs-call-compress-tmp2))) + (newname (symbol-value + (make-local-variable + 'efs-call-compress-newname))) + (filename (symbol-value + (make-local-variable + 'efs-call-compress-filename))) + (cont (symbol-value + (make-local-variable + 'efs-call-compress-cont))) + (nowait (symbol-value + (make-local-variable + 'efs-call-compress-nowait))) + (ok (symbol-value + (make-local-variable + 'efs-call-compress-ok))) + (uncompress + (symbol-value + (make-local-variable + 'efs-call-compress-uncompress)))) + (if efs-verbose + (efs-message + (format "%s %s...done" + (if uncompress + "Uncompressing" + "Compressing") + (symbol-value + (make-local-variable + 'efs-call-compress-abbr))))) + (kill-buffer (current-buffer)) + (efs-copy-file-internal + tmp2 nil newname (efs-ftp-path newname) + ok nil 1 + (efs-cont (result line cont-lines) (cont + tmp2 + filename) + (efs-del-tmp-name tmp2) + (or result + (let (efs-verbose) + (efs-delete-file filename) + (dired-remove-file filename))) + (if cont + (efs-call-cont cont result line + cont-lines))) + nowait (if uncompress nil 'image))))) + (error "Strange error: %s" proc)))))))))) + nowait (if uncompress 'image nil)))) + +(defun efs-update-mode-string (perms modes) + ;; For PERMS of the form `u+w', and MODES a unix 9-character mode string, + ;; computes the new mode string. + ;; Doesn't call efs-save-match-data. The calling function should. + (or (string-match "^[augo]+\\([+-]\\)[rwxst]+$" perms) + (error "efs-update-mode-string: invalid perms %s" perms)) + (let* ((who (substring perms 0 (match-beginning 1))) + (add (= (aref perms (match-beginning 1)) ?+)) + (what (substring perms (match-end 1))) + (newmodes (copy-sequence modes)) + (read (string-match "r" what)) + (write (string-match "w" what)) + (execute (string-match "x" what)) + (sticky (string-match "t" what)) + (suid (string-match "s" what))) + (if (string-match "a" who) + (if add + (progn + (if read + (progn + (aset newmodes 0 ?r) + (aset newmodes 3 ?r) + (aset newmodes 6 ?r))) + (if write + (progn + (aset newmodes 1 ?w) + (aset newmodes 4 ?w) + (aset newmodes 7 ?w))) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?s))) + (setq curr (aref newmodes 5)) + (if (= curr ?-) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?s))) + (setq curr (aref newmodes 8)) + (if (= curr ?-) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?t))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?S) + (if (= curr ?x) + (aset newmodes 2 ?s))) + (setq curr (aref newmodes 5)) + (if (= curr ?-) + (aset newmodes 5 ?S) + (if (= curr ?x) + (aset newmodes 5 ?s))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?T) + (if (= curr ?x) + (aset newmodes 8 ?t)))))) + (if read + (progn + (aset newmodes 0 ?-) + (aset newmodes 3 ?-) + (aset newmodes 6 ?-))) + (if write + (progn + (aset newmodes 1 ?-) + (aset newmodes 4 ?-) + (aset newmodes 7 ?-))) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?x) + (aset newmodes 2 ?-) + (if (= curr ?s) + (aset newmodes 2 ?S))) + (setq curr (aref newmodes 5)) + (if (= curr ?x) + (aset newmodes 5 ?-) + (if (= curr ?s) + (aset newmodes 5 ?S))) + (setq curr (aref newmodes 8)) + (if (= curr ?x) + (aset newmodes 8 ?-) + (if (= curr ?t) + (aset newmodes 8 ?T))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?s) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?-))) + (setq curr (aref newmodes 5)) + (if (= curr ?s) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?-))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?t) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?-)))))) + (if (string-match "u" who) + (if add + (progn + (if read + (aset newmodes 0 ?r)) + (if write + (aset newmodes 1 ?w)) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?s))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?S) + (if (= curr ?x) + (aset newmodes 2 ?s)))))) + (if read + (aset newmodes 0 ?-)) + (if write + (aset newmodes 1 ?-)) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?x) + (aset newmodes 2 ?-) + (if (= curr ?s) + (aset newmodes 2 ?S))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?s) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?-))))))) + (if (string-match "g" who) + (if add + (progn + (if read + (aset newmodes 3 ?r)) + (if write + (aset newmodes 4 ?w)) + (if execute + (let ((curr (aref newmodes 5))) + (if (= curr ?-) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?s))))) + (if suid + (let ((curr (aref newmodes 5))) + (if (= curr ?-) + (aset newmodes 5 ?S) + (if (= curr ?x) + (aset newmodes 5 ?s)))))) + (if read + (aset newmodes 3 ?-)) + (if write + (aset newmodes 4 ?-)) + (if execute + (let ((curr (aref newmodes 5))) + (if (= curr ?x) + (aset newmodes 5 ?-) + (if (= curr ?s) + (aset newmodes 5 ?S))))) + (if suid + (let ((curr (aref newmodes 5))) + (if (= curr ?s) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?-))))))) + (if (string-match "o" who) + (if add + (progn + (if read + (aset newmodes 6 ?r)) + (if write + (aset newmodes 7 ?w)) + (if execute + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?t))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?T) + (if (= curr ?x) + (aset newmodes 5 ?t)))))) + (if read + (aset newmodes 6 ?-)) + (if write + (aset newmodes 7 ?-)) + (if execute + (let ((curr (aref newmodes 8))) + (if (= curr ?x) + (aset newmodes 8 ?-) + (if (= curr ?t) + (aset newmodes 8 ?T))))) + (if suid + (let ((curr (aref newmodes 8))) + (if (= curr ?t) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?-)))))))) + newmodes)) + +(defun efs-compute-chmod-arg (perms file) + ;; Computes the octal number, represented as a string, required to + ;; modify the permissions PERMS of FILE. + (efs-save-match-data + (cond + ((string-match "^[0-7][0-7]?[0-7]?[0-7]?$" perms) + perms) + ((string-match "^[augo]+[-+][rwxst]+$" perms) + (let ((curr-mode (nth 3 (efs-get-file-entry file)))) + (or (and curr-mode + (stringp curr-mode) + (= (length curr-mode) 10)) + (progn + ;; Current buffer is process error buffer + (insert "Require an octal integer to modify modes for " + file ".\n") + (error "Require an octal integer to modify modes for %s." file))) + (format "%o" + (efs-parse-mode-string + (efs-update-mode-string perms + (substring curr-mode 1)))))) + (t + (insert "Don't know how to set modes " perms " for " file ".\n") + (error "Don't know how to set modes %s" perms))))) + +(defun efs-call-chmod (args) + ;; Sends an FTP CHMOD command. + (if (< (length args) 2) + (error "efs-call-chmod: missing mode and/or filename: %s" args)) + (let ((mode (car args)) + bombed) + (mapcar + (function + (lambda (file) + (setq file (expand-file-name file)) + (let ((parsed (efs-ftp-path file))) + (if parsed + (condition-case nil + (let* ((mode (efs-compute-chmod-arg mode file)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (efs-quote-string + (efs-host-type host user) (nth 2 parsed))) + (abbr (efs-relativize-filename file)) + (result (efs-send-cmd host user + (list 'quote 'site 'chmod + mode path) + (format "doing chmod %s" + abbr)))) + (efs-del-from-ls-cache file t) + (if (car result) + (efs-error host user (format "chmod: %s: \"%s\"" file + (nth 1 result))))) + (error (setq bombed t))))))) + (cdr args)) + (if bombed 1 0))) ; return code + +(defun efs-call-lpr (file command-format) + "Print remote file FILE. SWITCHES are passed to the print program." + ;; Works asynch. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (abbr (efs-relativize-filename file)) + (temp (car (efs-make-tmp-name nil (car parsed))))) + (efs-copy-file-internal + file parsed temp nil t nil 2 + (efs-cont (result line cont-lines) (command-format file abbr temp) + (if result + (signal 'ftp-error (list "Opening input file" + (format "FTP Error: \"%s\" " line) + file)) + (message "Spooling %s..." abbr) + (set-process-sentinel + (start-process (format "*print %s /// %s*" abbr temp) + (generate-new-buffer-name " *print temp*") + "sh" "-c" (format command-format temp)) + (function + (lambda (proc status) + (let ((buff (process-buffer proc)) + (name (process-name proc))) + (if (and buff (get-buffer buff)) + (unwind-protect + (save-excursion + (set-buffer buff) + (if (> (buffer-size) 0) + (let ((log-buff (get-buffer-create + "*Shell Command Output*"))) + (set-buffer log-buff) + (goto-char (point-max)) + (or (bobp) + (insert "\n")) + (insert-buffer-substring buff) + (goto-char (point-max)) + (display-buffer log-buff)))) + (condition-case nil (kill-buffer buff) (error nil)) + (efs-save-match-data + (if (string-match "^\\*print \\(.*\\) /// \\(.*\\)\\*$" + name) + (let ((abbr (substring name (match-beginning 1) + (match-end 1))) + (temp (substring name (match-beginning 2) + (match-end 2)))) + (or (= (match-beginning 2) (match-end 2)) + (efs-del-tmp-name temp)) + (message "Spooling %s...done" abbr)))))))))))) + t))) + +;;;; -------------------------------------------------------------- +;;;; Attaching onto dired. +;;;; -------------------------------------------------------------- + +;;; Look out for MULE +(if (or (boundp 'MULE) (featurep 'mule)) (load "efs-dired-mule")) + +;;; Magic file name hooks for dired. + +(put 'dired-print-file 'efs 'efs-dired-print-file) +(put 'dired-make-compressed-filename 'efs 'efs-dired-make-compressed-filename) +(put 'dired-compress-file 'efs 'efs-dired-compress-file) +(put 'dired-recursive-delete-directory 'efs + 'efs-dired-recursive-delete-directory) +(put 'dired-uncache 'efs 'efs-dired-uncache) +(put 'dired-shell-call-process 'efs 'efs-dired-shell-call-process) +(put 'dired-shell-unhandle-file-name 'efs 'efs-dired-shell-unhandle-file-name) +(put 'dired-file-modtime 'efs 'efs-dired-file-modtime) +(put 'dired-set-file-modtime 'efs 'efs-dired-set-file-modtime) + +;;; Overwriting functions + +(efs-overwrite-fn "efs" 'dired-call-process) +(efs-overwrite-fn "efs" 'dired-insert-headerline) +(efs-overwrite-fn "efs" 'dired-manual-move-to-filename) +(efs-overwrite-fn "efs" 'dired-manual-move-to-end-of-filename) +(efs-overwrite-fn "efs" 'dired-make-filename-string) +(efs-overwrite-fn "efs" 'dired-flag-backup-files) +(efs-overwrite-fn "efs" 'dired-create-files) +(efs-overwrite-fn "efs" 'dired-find-file) +(efs-overwrite-fn "efs" 'dired-find-file-other-window) +(efs-overwrite-fn "efs" 'dired-find-file-other-frame) +(efs-overwrite-fn "efs" 'dired-collect-file-versions) +(efs-overwrite-fn "efs" 'dired-file-name-lessp) + +;;; Hooks + +(add-hook 'dired-before-readin-hook 'efs-dired-before-readin) + +;;; Handle dired-grep.el too. + +(if (featurep 'dired-grep) + (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file + 'efs-diff/grep-del-temp-file) + (add-hook 'dired-grep-load-hook + (function + (lambda () + (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file + 'efs-diff/grep-del-temp-file))))) + +;;; end of efs-dired.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-dl.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dl.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,145 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dl.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Unix descriptive listing support for efs +;; Author: Sandy Rutherford +;; Created: Wed Jan 13 19:19:20 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:29:41 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-unix:dl) +(require 'efs) + +(defconst efs-dl-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; Unix descriptive listing (dl) support for efs +;;;----------------------------------------------------------------- + +;; this is also defined in efs.el, because it used to recognize +;; a dl listing. We re-define it here just to keep the dl stuff self-contained. + +(defconst efs-unix:dl-listing-regexp + "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") + +;; entry point + +(efs-defun efs-parse-listing unix:dl + (host user dir path &optional switches) + ;; Parse the current buffer, which is assumed to be a unix descriptive + ;; listing, and return a hashtable. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + ;; Is it really a listing? + (efs-save-match-data + (if (re-search-forward efs-unix:dl-listing-regexp nil t) + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (while (not (eobp)) + (efs-put-hash-entry + (buffer-substring (point) + (progn + (skip-chars-forward "^ /\n") + (point))) + (list (eq (following-char) ?/)) + tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Support for tree dired. + +(defconst efs-dired-dl-re-dir + "^. [^ /]+/[ \n]" + "Regular expression to use to search for dl directories.") + +(or (assq 'unix:dl efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'unix:dl efs-dired-dl-re-dir) + efs-dired-re-dir-alist))) + + +(efs-defun efs-dired-manual-move-to-filename unix:dl + (&optional raise-error bol eol) + ;; In dired, move to the first character of the filename on this line. + ;; This is the Unix dl version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and + (> (- eol bol) 3) + (progn + (forward-char 2) + (skip-chars-forward " \t") + (looking-at "[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) "))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename unix:dl + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Unix dl version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^ /\r\n\t") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?/)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline unix:dl (dir) + ;; Unix dl has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing unix:dl (file path &optional + switches wildcard) + ;; Deal with continuation lines. + (efs-save-match-data + (goto-char (point-min)) + (while (re-search-forward "\n +" nil t) + (delete-region (match-beginning 0) (match-end 0)) + (insert " ")))) + +;;; end of efs-dl.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-dos-distinct.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dos-distinct.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,152 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dos-distinct.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Distinct's DOS FTP server support for efs +;; Author: Sandy Rutherford +;; Created: Fri Jan 15 22:20:32 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:30:04 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks to Rodd Zurcher for beta testing. + +(provide 'efs-dos-distinct) +(require 'efs) + +(defconst efs-dos-distinct-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ----------------------------------------------------------------- +;;;; Distinct's DOS FTP server support for efs +;;;; ----------------------------------------------------------------- + +;;; This is not included in efs-dos.el with the support for the +;;; other dos ftp servers, because the Distinct server uses unix syntax +;;; for path names. + +;; This is defined in efs.el, but we put it here too. + +(defconst efs-dos-distinct-date-and-time-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " + "[ 12][0-9]:[0-5][0-9] ")) + +;;; entry point + +(efs-defun efs-parse-listing dos-distinct + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; Distinct's DOS FTP server. Both empty dirs, and ls errors return + ;; empty buffers. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a full remote path + ;; PATH = directory in full efs-path syntax + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-dos-distinct-date-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + dir-p) + (beginning-of-line) + (while (progn + (setq dir-p (eq (following-char) ?d)) ; we're bolp + (re-search-forward + efs-dos-distinct-date-and-time-regexp nil t)) + (efs-put-hash-entry (buffer-substring (point) + (progn (end-of-line) + (point))) + (list dir-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup dos-distinct (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Subdirs in DOS can't have an extension. + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-dos-distinct-re-exe + "^[^\n]+\\.exe$") + +(or (assq 'dos-distinct efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos-distinct efs-dired-dos-distinct-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos-distinct-re-dir + "^. [ \t]*d") + +(or (assq 'dos-distinct efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos-distinct efs-dired-dos-distinct-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos-distinct (dir) + ;; The Distinct DOS server has no total line, so we insert a + ;; blank line for aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos-distinct + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for Distinct's DOS FTP server. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos-distinct-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos-distinct + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the version for Distinct's DOS FTP server. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; it's hidden or omitted + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-z0-9.$") + (if (or (= opoint (point)) (not (memq (following-char) '(\n \r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-dos-distinct.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-fnh.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-fnh.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,147 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-fnh.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Look for the emacs version, and install into +;; the file-name-handler-alist +;; Author: Sandy Rutherford +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Although used by efs, these utilities could be of general use to other +;;; packages too. Keeping them separate from the main efs program +;;; makes it easier for other programs to require them. + +(provide 'efs-fnh) + +(defconst efs-fnh-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.2 $" 11 -2))) + +;;;; ---------------------------------------------------------------- +;;;; Loading emacs version files +;;;; ---------------------------------------------------------------- + +(defun efs-handle-emacs-version () + ;; Load appropriate files for the current emacs version + (let ((ehev-match-data (match-data))) + (unwind-protect + (let ((lucidp (string-match "Lucid" emacs-version)) + ver subver) + (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) + (error "efs does not work with emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version + (match-beginning 1) + (match-end 1))) + subver (string-to-int (substring emacs-version + (match-beginning 2) + (match-end 2)))) + (cond + + ;; Lucid XEmacs (emacs-version looks like \"19.xx XEmacs Lucid\") + (lucidp + (cond + ((and (= ver 19) (>= subver 11) (< subver 15)) + (require 'efs-l19\.11)) + ((and (= ver 19) (>= subver 15)) + (require 'efs-x19\.15)) + ((= ver 20) + (require 'efs-x19\.15)) + (t + (error + "efs does not work with emacs version %s" emacs-version)))) + + ;; Original GNU Emacs from FSF + (t + (cond + ((and (= ver 19) (<= subver 22)) + (require 'efs-19)) + ((and (= ver 19) (>= subver 23)) + (require 'efs-19\.23)) + + ;; GNU Emacs 18- + ((<= ver 18) + (require 'efs-18)) ; this file will (require 'emacs-19) + + (t + (error + "efs does not work with emacs version %s" emacs-version)))))) + + (store-match-data ehev-match-data)))) + +;;;; -------------------------------------------------------------- +;;;; Stuff for file name handlers. +;;;; -------------------------------------------------------------- + +;;; Need to do this now, to make sure that the file-name-handler-alist is +;;; defined for Emacs 18. + +(efs-handle-emacs-version) + +;; Also defined in efs-cu.el +(defvar efs-path-root-regexp "^/[^/:]+:" + "Regexp to match the `/user@host:' root of an efs full path.") + +(defun efs-file-name-handler-alist-sans-fn (fn) + ;; Returns a version of file-name-handler-alist without efs. + (delq nil (mapcar + (function + (lambda (x) + (and (not (eq (cdr x) fn)) x))) + file-name-handler-alist))) + +(defun efs-root-handler-function (operation &rest args) + "Function to handle completion in the root directory." + (let ((handler (get operation 'efs-root))) + (if handler + (apply handler args) + (let ((inhibit-file-name-handlers + (cons 'efs-root-handler-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))))) + +(put 'file-name-completion 'efs-root 'efs-root-file-name-completion) +(put 'file-name-all-completions 'efs-root 'efs-root-file-name-all-completions) +(autoload 'efs-root-file-name-all-completions "efs-netrc") +(autoload 'efs-root-file-name-completion "efs-netrc") + +(autoload 'efs-file-handler-function "efs" + "Function to use efs to handle remote files.") + +;; Install into the file-name-handler-alist. +;; If we are already there, remove the old entry, and re-install. +;; Remove the ange-ftp entry too. + +(setq file-name-handler-alist + (let (dired-entry alist) + (setq alist + (nconc + (list + (cons efs-path-root-regexp 'efs-file-handler-function) + '("^/$" . efs-root-handler-function)) + (delq nil + (mapcar + (function + (lambda (x) + (if (eq (cdr x) 'dired-handler-fn) + (progn + (setq dired-entry x) + nil) + (and (not + (memq (cdr x) + '(efs-file-handler-function + efs-root-handler-function + ange-ftp-hook-function + ange-ftp-completion-hook-function))) + x)))) + file-name-handler-alist)))) + ;; Make sure that dired is in first. + (if dired-entry (cons dired-entry alist) alist))) + +;;; end of efs-fnh.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-guardian.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-guardian.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,241 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-guardian.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Guardian support for efs +;; Author: Sandy Rutherford +;; Created: Sat Jul 10 12:26:12 1993 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Acknowledgements: +;;; Adrian Philips and David Karr for answering questions +;;; and debugging. Thanks. + +(defconst efs-guardian-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(provide 'efs-guardian) +(require 'efs) + +;;;; ------------------------------------------------------------ +;;;; Support for Tandem's GUARDIAN operating system. +;;;; ------------------------------------------------------------ + +;;; Supposed to work for (Version 2.7 TANDEM 01SEP92). + +;;; File name syntax: +;;; +;;; File names are of the form volume.subvolume.file where +;;; volume is $[alphanumeric characters]{1 to 7} +;;; subvolume is []{0 to 7} +;;; and file is the same as subvolume. + +(defconst efs-guardian-date-regexp + (concat + " [ 1-3][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|" + "Sep\\|Oct\\|Nov\\|Dec\\)-[0-9][0-9] ")) + +;;; entry points -- 2 of 'em. + +(efs-defun efs-fix-path guardian (path &optional reverse) + ;; Convert PATH from unix-ish to guardian. + ;; If REVERSE is non-nil do just that. + (efs-save-match-data + (let ((case-fold-search t)) + (if reverse + (if (string-match + (concat + "^\\(\\\\[A-Z0-9]+\\.\\)?" + "\\(\\$[A-Z0-9]+\\)\\.\\([A-Z0-9]+\\)\\(\\.[A-Z0-9]+\\)?$") + path) + (concat + "/" + (substring path (match-beginning 2) (match-end 2)) + "/" + (substring path (match-beginning 3) (match-end 3)) + "/" + (and (match-beginning 4) + (substring path (1+ (match-beginning 4))))) + (error "path %s is invalid for the GUARDIAN operating system" + path)) + (if (string-match + "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" path) + (apply 'concat + (substring path 1 (match-end 1)) + "." + (substring path (match-beginning 2) (match-end 2)) + (and (match-beginning 3) + (/= (- (match-end 3) (match-beginning 3)) 1) + (list "." + (substring path (1+ (match-beginning 3)))))) + (error "path %s is invalid for the guardian operating system" + path)))))) + +(efs-defun efs-fix-dir-path guardian (dir-path) + ;; Convert DIR-PATH from unix-ish to guardian fir a DIR listing. + (efs-save-match-data + (let ((case-fold-search t)) + (cond + ((string-equal "/" dir-path) + (error "Can't grok guardian disk volumes.")) + ((string-match "^/\\$[A-Z0-9]+/?$" dir-path) + (error "Can't grok guardian subvolumes.")) + ((string-match "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" + dir-path) + (apply 'concat + (substring dir-path 1 (match-end 1)) + "." + (substring dir-path (match-beginning 2) (match-end 2)) + (and (match-beginning 3) + (/= (- (match-end 3) (match-beginning 3)) 1) + (list "." + (substring dir-path (1+ (match-beginning 3))))))) + (t + (error "path %s is invalid for the guardian operating system")))))) + +(efs-defun efs-parse-listing guardian + (host user dir path &optional switches) + ;; Parses a GUARDIAN DIRectory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (efs-save-match-data + (goto-char (point-min)) + (if (re-search-forward efs-guardian-date-regexp nil t) + (let ((tbl (efs-make-hashtable)) + file size) + (while + (progn + (beginning-of-line) + (setq file (buffer-substring (point) + (progn + (skip-chars-forward "A-Z0-9") + (point)))) + (skip-chars-forward " ") + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq size (string-to-int (buffer-substring + (point) + (progn + (skip-chars-forward "0-9"))))) + (efs-put-hash-entry file (list nil size) tbl) + (forward-line 1) + (re-search-forward efs-guardian-date-regexp nil t))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup guardian (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + (efs-save-match-data + (let ((case-fold-search t)) + (string-match "^/\\$[A-Z0-9]+/$" dir)))) + +(efs-defun efs-internal-file-directory-p guardian (file) + ;; Directories pop into existence simply by putting files in them. + (efs-save-match-data + (let ((case-fold-search t)) + (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) + t + (efs-internal-file-directory-p nil file))))) + +(efs-defun efs-internal-file-exists-p guardian (file) + ;; Directories pop into existence simply by putting files in them. + (efs-save-match-data + (let ((case-fold-search t)) + (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) + t + (efs-internal-file-exists-p nil file))))) + +;;; Tree Dired support + +(defconst efs-dired-guardian-re-exe nil) + +(or (assq 'guardian efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'guardian efs-dired-guardian-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-guardian-re-dir nil) + +(or (assq 'guardian efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'guardian efs-dired-guardian-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename guardian + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the guardian version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (save-excursion (re-search-forward efs-guardian-date-regexp eol t)) + (progn + (if (looking-at ". [^ ]") + (forward-char 2)) + (point)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename guardian + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the guardian version. + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (and + (>= (following-char) ?A) + (<= (following-char) ?Z) + (progn + (skip-chars-forward "A-Z0-9") + (= (following-char) ?\ ))) + (point) + (and (null no-error) + (error "No file on this line")))) + +(efs-defun efs-dired-ls-trim guardian () + (goto-char (point-min)) + (let (case-fold-search) + (if (re-search-forward efs-guardian-date-regexp nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max)))))) + +;;; end of efs-guardian.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-gwp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-gwp.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,158 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-gwp.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for efs to use an interactive gateway. +;; Author: Andy Norman, Dawn +;; Created: Thu Mar 18 13:03:14 1993 +;; Modified: Sun Nov 27 18:31:50 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-gwp) +(require 'efs) + +;;;; ------------------------------------------------------------ +;;;; Interactive gateway program support. +;;;; ------------------------------------------------------------ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; User Variables and Documentation + +(defvar efs-gwp-setup-term-command + (if (eq system-type 'hpux) + "stty -onlcr -echo\n" + "stty -echo nl\n") + "Command to do terminal setup on the gateway machine. +They must stop the terminal echoing each command and strip out trailing +^M characters. This string must end in \\n. If you need to send multiple +commands, include them all in this string, separated by \\n. +See the documentation in efs.el for some example commands.") + +;; About efs-gwp-term-setup-command: +;; +;; It is important to get efs-gwp-setup-term-command right. +;; Here are some examples. Please tell us about which commands +;; to use on other platforms, so that we can include it in the +;; documentation. +;; +;; +;; HP-UX: +;; +;; "stty -onlcr -echo\n" +;; +;; SunOS: +;; +;; "stty -echo nl\n" +;; +;; VMS: (this should work) +;; +;; "set terminal/noecho\n" +;; + + +(defvar efs-gwp-prompt-pattern "^[^#$%>;]*[#$%>;] *" + "*Regexp used to detect that the gateway login sequence has completed. +It will be assumed that the shell is ready to receive input. Make this +regexp as strict as possible; it shouldn't match *anything* at all except +the shell's initial prompt. The above string will fail under most SUN-3's +since it matches the login banner.") + +;; About efs-gwp-prompt-pattern: +;; +;; It is very important that this not match anything in the machine's +;; login banner. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Internal Variables + +(defconst efs-gwp-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-gwp-running t) +(defvar efs-gwp-status nil) +(defvar efs-gwp-string "") + +;;; Entry point (defined as an autoload in efs.el) + +(defun efs-gwp-start (host user name) + "Login to the gateway machine and fire up an ftp process." + (message "Connecting to gateway %s..." efs-gateway-host) + (let ((proc (apply 'start-process name (efs-ftp-process-buffer host user) + (nth 1 efs-gateway-type) + (append (nth 2 efs-gateway-type) + (list efs-gateway-host)))) + (ftp (concat (nth 3 efs-gateway-type) " " + (mapconcat (function identity) (nth 4 efs-gateway-type) + " ") "\n"))) + (process-kill-without-query proc) + (set-process-sentinel proc (function efs-gwp-sentinel)) + (set-process-filter proc (function efs-gwp-filter)) + (set-marker (process-mark proc) (point)) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (while efs-gwp-running ;perform login sequence + (accept-process-output proc)) + (if (not efs-gwp-status) + (efs-error host user "unable to login to gateway")) + (message "Connecting to gateway %s...done" efs-gateway-host) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (process-send-string proc efs-gwp-setup-term-command) + (while efs-gwp-running ;zap ^M's and double echoing. + (accept-process-output proc)) + (if (not efs-gwp-status) + (efs-error host user "unable to set terminal modes on gateway")) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (message "Opening FTP connection to %s..." host) + (process-send-string proc ftp) + proc)) + +;;; Process filter/sentinel + +(defun efs-gwp-sentinel (proc str) + (setq efs-gwp-running nil)) + +(defun efs-gwp-filter (proc str) + (efs-save-match-data + ;; Don't be sensitive to login vn LOGIN. + (let ((case-fold-search t)) + (efs-process-log-string proc str) + (setq efs-gwp-string (concat efs-gwp-string str)) + (cond ((string-match "\\(login\\|username\\): *$" efs-gwp-string) + (process-send-string proc + (concat + (let ((efs-default-user t)) + (efs-get-user efs-gateway-host)) + "\n"))) + ((string-match "password: *$" efs-gwp-string) + (process-send-string proc + (concat + (efs-get-passwd efs-gateway-host + (efs-get-user + efs-gateway-host)) + "\n"))) + ((string-match efs-gateway-fatal-msgs + efs-gwp-string) + (delete-process proc) + (setq efs-gwp-running nil)) + ((string-match efs-gwp-prompt-pattern + efs-gwp-string) + (setq efs-gwp-running nil + efs-gwp-status t)))))) + +;;; end of efs-gwp.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-hell.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-hell.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,185 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-hell.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Hellsoft FTP server support for efs +;; Author: Sandy Rutherford +;; Created: Tue May 25 02:31:37 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:32:27 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-hell) +(require 'efs) + +(defconst efs-hell-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; -------------------------------------------------------------- +;;;; Hellsoft FTP server support for efs +;;;; -------------------------------------------------------------- + +;;; The hellsoft FTP server runs on DOS PC's and Macs. The hellsoft +;;; support here probably won't work for Macs. If enough people need it +;;; the Mac support _might_ be fixed. + +;;; Works for "novell FTP Server for NW 3.11 (v1.8), (c) by HellSoft." + +;; Hellsoft uses unix path syntax. However, we shouldn't append a "." +;; to directories, because if foobar is a plain file, then +;; dir foobar/ will not give a listing (which is correct), but +;; dir foobar/. will give a one-line listing (which is a little strange). + +(efs-defun efs-fix-dir-path hell (dir-path) + dir-path) + +;; Hellsoft returns PWD output in upper case, whereas dir listings are +;; in lower case. To avoid confusion, downcase pwd output. + +(efs-defun efs-send-pwd hell (host user &optional xpwd) + ;; Returns ( DIR . LINE ), where DIR is either the current directory, or + ;; nil if this couldn't be found. LINE is the line of output from the + ;; FTP server. Since the hellsoft server returns pwd output in uppercase, we + ;; downcase it. + (let ((result (efs-send-pwd 'unix host user xpwd))) + (if (car result) + (setcar result (downcase (car result)))) + result)) + +(defconst efs-hell-date-and-time-regexp + (concat + " \\([0-9]+\\) \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [0-3][0-9] " + "\\([012][0-9]:[0-5][0-9]\\| [12][019][0-9][0-9]\\) ")) +;; The end of this regexp corresponds to the start of a filename. + +(defmacro efs-hell-parse-file-line () + ;; Returns ( FILENAME DIR-P SIZE ) from the current line + ;; of a hellsoft listing. Assumes that the point is at the beginning + ;; of the line. + (` (let ((eol (save-excursion (end-of-line) (point))) + (dir-p (= (following-char) ?d))) + (if (re-search-forward efs-hell-date-and-time-regexp eol t) + (list (buffer-substring (point) (progn (end-of-line) (point))) + dir-p + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))))))) + +(efs-defun efs-parse-listing hell + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; a Hellsoft FTP server. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a full remote path + ;; PATH = directory in full efs-path syntax + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-hell-date-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + file-info) + (beginning-of-line) + (while (setq file-info (efs-hell-parse-file-line)) + (efs-put-hash-entry (car file-info) (cdr file-info) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl) + (if (not (string-match (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name dir)) "\\.")) + ;; It's an empty dir + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + + +(efs-defun efs-allow-child-lookup hell (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Subdirs in DOS can't have an extension. + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-hell-re-exe + "^[^\n]+\\.exe$") + +(or (assq 'hell efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'hell efs-dired-hell-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-hell-re-dir + "^. [ \t]*d") + +(or (assq 'hell efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'hell efs-dired-hell-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename hell + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line, where + ;; line can be delimited by either \r or \n. + ;; Returns (point) or nil if raise-error is nil and there is no + ;; filename on this line. In the later case, leaves the point at the + ;; beginning of the line. + ;; This version is for the Hellsoft FTP server. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-hell-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename hell + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the Hellsoft FTP server version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-zA-Z0-9.$~") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline hell (dir) + ;; Insert a blank line for aesthetics + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +;;; end of efs-hell.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-ka9q.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ka9q.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,190 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ka9q.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: KA9Q support for efs +;; Author: Sandy Rutherford +;; Created: Mon Dec 21 10:34:43 1992 by sandy on ibm550 +;; Modified: Sun Nov 27 18:32:56 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks go to Joe Reinhardt for beta testing. + +(provide 'efs-ka9q) +(require 'efs) + +(defconst efs-ka9q-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; KA9Q support for efs +;;;----------------------------------------------------------------- +;;; +;;; KA9Q is not really an OS, but an ftp server that runs on PC's. +;;; It runs under DOS and unix. Seems to have been adopted by LINUX. + +;; KA9Q uses unix syntax for paths, so don't need to bother with pathname +;; converters. It always gives a listing, even if a file or dir doesn't +;; exist. Therefore, we shall assume that empty dir = nonexistent dir. sigh... + +(defconst efs-ka9q-date-regexp + " +[.,0-9]* [ 0-2][0-9]:[0-9][0-9] +[0-9]+/[0-9]+/[0-9]+") + ;; (match-beginning 0) should be the last char of the filename. + +(defun efs-ka9q-bogus-listing (dir path) + ;; Check to see if a 1-line ka9q listing is bogus, and the directory + ;; is really just a file. + (and + (not (string-equal "/" dir)) + (goto-char (point-min)) + (looking-at (regexp-quote + (concat (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name dir)) + " "))) + (forward-line 1) + (looking-at "1 file\\. ") + (string-match "^No files\\. " + ;; ls switches don't matter + (efs-ls (concat path "*") "-al" t t)))) + +(efs-defun efs-parse-listing ka9q + (host user dir path &optional switches) + ;; Parse the current listing which is assumed to be a ka9q listing. + ;; Format is based on version 890421.1a.linux.7 (whatever that means). + ;; Note that ka9q uses two files per line. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + dir-p file) + (efs-save-match-data + (if (and + (progn + (goto-char (point-max)) + (forward-line -1) + ;; Although "No files." may refer to an empty + ;; directory, it may also be a non-existent + ;; dir. Returning nil should force a listing + ;; of the parent, which will sort things out. + (looking-at "[0-9]+ files?\\. ")) + ;; Check for a bogus listing. + (not (efs-ka9q-bogus-listing dir path))) + (progn + (goto-char (point-min)) + (while (re-search-forward efs-ka9q-date-regexp nil t) + (goto-char (match-beginning 0)) + (if (setq dir-p (eq (preceding-char) ?/)) + (forward-char -1)) + (setq file (buffer-substring (point) + (progn (skip-chars-backward "^ \n") + (point)))) + (efs-put-hash-entry file (list dir-p) tbl) + (goto-char (match-end 0))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +;;; Tree Dired + +(defconst efs-dired-ka9q-re-exe + "^. [^ \n\r./]+\\.exe ") + +(or (assq 'ka9q efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'ka9q efs-dired-ka9q-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-ka9q-re-dir + "^. [^ \n\r/]+/ ") + +(or (assq 'ka9q efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ka9q efs-dired-ka9q-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-fixup-listing ka9q (file path &optional switches wildcard) + ;; ka9q puts two files per line. Need to put in one file per line format + ;; for dired. + (let ((regexp (concat efs-ka9q-date-regexp " "))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-char -3) + (insert-char ?\n 1)) + ;; is there a blank line left? + (if (looking-at "[ \t]*\n") + (delete-region (match-beginning 0) (match-end 0))))) + +(efs-defun efs-dired-ls-trim ka9q () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (forward-line 1) + (if (looking-at "\\([0-9]+\\|No\\) files?\\. ") + (delete-region (point) (point-max))))) + +(efs-defun efs-dired-insert-headerline ka9q (dir) + ;; Insert a headerline + (insert-char ?\n 1) + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename ka9q + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This is the KA9Q version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-ka9q-date-regexp eol t) + (progn + (goto-char (match-beginning 0)) + (skip-chars-backward "^ " bol) + (point)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ka9q + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the KA9Q version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^ \n\r/") + (if (or (= opoint (point)) (not (memq (following-char) '(?/ ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-ka9q.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-kerberos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-kerberos.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,136 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-efs-kerberos.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for Kerberos gateways. +;; Author: Sandy Rutherford +;; Created: Thu Nov 24 21:19:25 1994 by sandy on gandalf +;; Modified: +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Support for the Kerberos gateway authentication system from MIT's +;;; Project Athena. + +(provide 'efs-kerberos) +(require 'efs) + +(defconst efs-kerberos-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Internal Variables + +(defvar efs-kerberos-passwd-sent nil) +;; Set to t after the passwd has been sent. +(defvar efs-kerberos-output "") +;; Holds the output lines from the kinit process. +(defvar efs-kerberos-buffer-name "*efs kerberos*") +;; Buffer where kinit output is logged. +(defvar efs-kerberos-passwd-prompt-regexp "^Password: *$") +;; Regular expression to match prompt used by the kinit program. +(defvar efs-kerberos-failed-msgs "[^ ]+") +;; Regular expression to match output for an invalid kinit ticket password. +;; Is this too general? +(defvar efs-kerberos-passwd-failed nil) +;; Whether the kinit command worked. +(defvar efs-kerberos-passwd-retry nil) + +;;; Code + +(defun efs-kerberos-process-filter (proc str) + ;; Process filter for the kinit process. + (setq efs-kerberos-output (concat efs-kerberos-output str)) + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (efs-save-match-data + (goto-char (point-max)) + (while (string-match "\n" efs-kerberos-output) + (let ((line (substring efs-kerberos-output 0 + (match-beginning 0)))) + (insert line "\n") + (and efs-kerberos-passwd-sent + (string-match efs-kerberos-failed-msgs line) + (setq efs-kerberos-passwd-failed t))) + (setq efs-kerberos-output (substring efs-kerberos-output + (match-end 0)))) + (and (null efs-kerberos-passwd-sent) + (string-match efs-kerberos-passwd-prompt-regexp + efs-kerberos-output) + (memq (process-status proc) '(run open)) + (let ((passwd (or + (efs-lookup-passwd efs-gateway-host "kerberos") + (read-passwd + (if efs-kerberos-passwd-retry + "Password failed. Try again: " + (format "Kerberos password for %s: " + efs-gateway-host)))))) + (unwind-protect + (progn + (insert efs-kerberos-output) + (setq efs-kerberos-output "") + (process-send-string proc passwd) + (insert "Turtle Power!\n")) + (fillarray passwd 0))))))))) + +(defun efs-kerberos-get-ticket () + ;; Gets a kerbos ticket. The password is actually sent by the process + ;; filter. + (let ((mess (format "Getting kerberos ticket for %s..." efs-gateway-host))) + (message mess) + (setq efs-kerberos-passwd-failed nil + efs-kerberos-passwd-sent nil + efs-kerberos-output "") + (condition-case nil (delete-process "*efs kerberos*") (eror nil)) + (let* ((program (or (nth 3 efs-gateway-type) "kinit")) + (args (nth 4 efs-gateway-type)) + (proc (apply 'start-process + "*efs kerberos*" efs-kerberos-buffer-name + program args))) + (set-process-filter proc (function efs-kerberos-process-filter)) + ;; Should check for a pty, but efs-pty-check will potentially eat + ;; important output. Need to wait until Emacs 19.29 to do this properly. + (while (memq (process-status proc) '(run open)) + (accept-process-output proc)) + (if efs-kerberos-passwd-failed + (let ((efs-kerberos-passwd-failed t)) + (efs-kerberos-get-ticket)))) + (message "%sdone" mess))) + +(defun efs-kerberos-login (host user proc) + ;; Open a connection using process PROC to HOST adn USER, using a + ;; kerberos gateway. Returns the process object of the connection. + ;; This may not be PROC, if a ticket collection was necessary. + (let ((to host) + result port cmd) + (if (string-match "#" host) + (setq to (substring host 0 (match-beginning 0)) + port (substring host (match-end 0)))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (setq to (efs-nslookup-host to))) + (setq cmd (concat "open " to)) + (if port (setq cmd (concat cmd " " port))) + (setq result (efs-raw-send-cmd proc cmd)) + (while (and (car result) + (string-match "\\bcannot authenticate to server\\b" + (nth 1 result))) + (let ((name (process-name proc))) + (condition-case nil (delete-process proc) (error nil)) + (efs-kerberos-get-ticket) + (setq proc (efs-start-process host user name) + result (efs-raw-send-cmd proc cmd)))) + (if (car result) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "OPEN request failed: " + (nth 1 result))))) + proc)) + +;;; End of efs-kerberos.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-l19.11.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-l19.11.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,175 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-l19.11.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for XEemacs, versions 19.11, and later. +;; Author: Sandy Rutherford +;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:34:33 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-l19\.11) +(require 'efs-cu) +(require 'default-dir) +(require 'efs-ovwrt) + +(defconst efs-l19\.11-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Functions requiring special defs. for these lemacs versions. + +(defun efs-abbreviate-file-name (filename &optional hack-homedir) + ;; lucid emacs version of abbreviate-file-name for remote files. + (let (file-name-handler-alist) + (if (and hack-homedir (efs-ftp-path filename)) + ;; Do replacements from directory-abbrev-alist + (apply 'efs-unexpand-parsed-filename + (efs-ftp-path (abbreviate-file-name filename nil))) + (abbreviate-file-name filename hack-homedir)))) + +(defun efs-relativize-filename (file &optional dir new) + "Abbreviate the given filename relative to DIR . +If DIR is nil, use the value of `default-directory'. If the +optional parameter NEW is given and the non-directory parts match, only return +the directory part of the file." + (let* ((dir (or dir default-directory)) + (dlen (length dir)) + (result file)) + (and (> (length file) dlen) + (string-equal (substring file 0 dlen) dir) + (setq result (substring file dlen))) + (and new + (string-equal (file-name-nondirectory result) + (file-name-nondirectory new)) + (or (setq result (file-name-directory result)) + (setq result "./"))) + (abbreviate-file-name result t))) + +(defun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because Lucid and FSF do this differently. + (setq buffer-file-name filename) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (compute-buffer-file-truename) + (setq buffer-file-truename filename))) + +;; Do we need to do anything about compute-buffer-file-truename, or +;; will the handler for file-truename handle this automatically? I suppose +;; that efs-compute-remote-buffer-file-truename should really apply to +;; compute-buffer-file-truename, and not file-truename, but then we would +;; have to do deal with the fact that this function doesn't exist in GNU Emacs. + +;; Only Lucid Emacs has this function. Why do we need both this and +;; set-visited-file-modtime? + +(defun efs-set-buffer-modtime (buffer &optional time) + ;; For buffers visiting remote files, set the buffer modtime. + (or time + (progn + (setq time + (let* ((file (save-excursion + (set-buffer buffer) buffer-file-name)) + (parsed (efs-ftp-path file))) + (efs-get-file-mdtm (car parsed) (nth 1 parsed) + (nth 2 parsed) file))) + (if time + (setq time (cons (car time) (nth 1 time))) + (setq time '(0 . 0))))) + (let (file-name-handler-alist) + (set-buffer-modtime buffer time))) + +;;; Need to add access to the file-name-handler-alist to these functions. + +(defun efs-l19\.11-set-buffer-modtime (buffer &optional time) + "Documented as original" + (let ((handler (save-excursion + (set-buffer buffer) + (and buffer-file-name + (find-file-name-handler buffer-file-name + 'set-buffer-modtime))))) + (if handler + (funcall handler 'set-buffer-modtime buffer time) + (let (file-name-handler-alist) + (efs-real-set-buffer-modtime buffer time))))) + +(efs-overwrite-fn "efs" 'set-buffer-modtime 'efs-l19\.11-set-buffer-modtime) + +(defun efs-l19\.11-backup-buffer () + "Documented as original" + (if buffer-file-name + (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) + (if handler + (funcall handler 'backup-buffer) + (let (file-name-handler-alist) + (efs-real-backup-buffer)))))) + +(efs-overwrite-fn "efs" 'backup-buffer 'efs-l19\.11-backup-buffer) + +(defun efs-l19\.11-create-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'create-file-buffer))) + (if handler + (funcall handler 'create-file-buffer file) + (let (file-name-handler-alist) + (efs-real-create-file-buffer file))))) + +(efs-overwrite-fn "efs" 'create-file-buffer 'efs-l19\.11-create-file-buffer) + +(defun efs-l19\.11-abbreviate-file-name (filename &optional hack-homedir) + "Documented as original" + (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename hack-homedir) + (let (file-name-handler-alist) + (efs-real-abbreviate-file-name filename hack-homedir))))) + +(efs-overwrite-fn "efs" 'abbreviate-file-name + 'efs-l19\.11-abbreviate-file-name) + +(defun efs-l19\.11-recover-file (file) + "Documented as original" + (interactive + (let ((prompt-file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and prompt-file + (setq file-name (file-name-nondirectory prompt-file) + file-dir (file-name-directory prompt-file))) + (list (read-file-name "Recover file: " + file-dir nil nil file-name)))) + (let* ((file (expand-file-name file)) + (handler (or (find-file-name-handler file 'recover-file) + (find-file-name-handler + (let ((buffer-file-name file)) + (make-auto-save-file-name)) + 'recover-file)))) + (if handler + (funcall handler 'recover-file file) + (efs-real-recover-file file)))) + +(efs-overwrite-fn "efs" 'recover-file 'efs-l19\.11-recover-file) + +(defun efs-l19\.11-substitute-in-file-name (filename) + "Documented as original." + (let ((handler (find-file-name-handler filename 'substitute-in-file-name))) + (if handler + (funcall handler 'substitute-in-file-name filename) + (let (file-name-handler-alist) + (efs-real-substitute-in-file-name filename))))) + +(efs-overwrite-fn "efs" 'substitute-in-file-name + 'efs-l19\.11-substitute-in-file-name) + +;;; For the file-name-handler-alist + +(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) + +;;; end of efs-l19.11.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-mpe.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mpe.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,678 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mpe.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MPE (HP3000) support for efs. +;; Author: (Corny de Souza) cdesouza@hpbbn.bbn.hp.com +;; Created: Fri Jan 15 12:58:29 1993 +;; Modified: Sun Nov 27 18:36:13 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Credits +;; +;; Sandy Rutherford for his help and advice. + +;;; Usage +;; +;; For a general description of remote file access see efs.el. +;; +;; MPE Specifics +;; +;; *) To make things easier (for me) MPE has been UNIXified so think UNIX +;; and you stand a good chance of understanding everything. +;; +;; *) Filename syntax is as follows +;; +;; /session,user.account,group@system:/account/group/file;buildparms +;; +;; the "session," and ",group" in the logon sequence are optional. +;; +;; e.g. /CDSUSER.OSCAR@SYSTEM41:/OSCAR/CDSSRC/TST0000S +;; will get the file TST0000S.CDSSRC.OSCAR +;; +;; The ";buildparms" is also optional. It should be used when creating +;; files whos characteristics differ from the default system buildparms, +;; described in the file FTPDOC.ARPA.SYS (at least it is on my system). +;; Also see variable efs-mpe-default-buildparms. +;; +;; e.g. REC=-256,,V,ASCII +;; +;; *) Password syntax is as follows +;; +;; userpass,accountpass,grouppass +;; +;; Leading commas cannot be omitted, trailing commas can. +;; e.g. USERPASS,ACCTPASS (no group password) +;; ,ACCTPASS (only account password) +;; USERPASS,,GRPPASS (no account password) +;; +;; *) Do not use account name completion on large systems. See the variable +;; efs-mpe-account-completion-confirm +;; +;; *) Do not use group name completion on large accounts. See the variable +;; efs-mpe-group-completion-confirm +;; +;; *) The buffers FILE and FILE;BUILDPARMS both point to the same physical +;; disc file. +;; +;; *) When using filename completion you will usually be given the option +;; between FILE and FILE;BUILDPARMS. Just ignore the FILE;BUILDPARMS +;; bit. +;; +;; *) WARNING ********* Two buffer for the same file ************ WARNING +;; If you land up with two buffers FILE and FILE;BUILDPARMS for the same +;; file kill the FILE;BUILDPARMS one. If however this is newwer than +;; the FILE buffer (and you cannot live with a buffer called +;; FILE;BUILDPARMS) save it kill both buffers and get the FILE buffer again. +;; +;; *) When creating new files only create FILES. It is possible to create +;; files as GROUPs and ACCOUNTs but don't! +;; +;;; To Do +;; +;; A lot of things are likely to change with MPE 4.5 and POSIX so I do not want +;; to invest too much time in this now. I would rather wait until I can see +;; what comes with POSIX. +;; +;; Feel free to send bugs, suggestions for enhancements and enhancements +;; to me cdesouza@hpbbn.bbn.hp.com. If I have TIME I will try to deal with +;; them. Also I'm not a lisp programmer so keep it simple or put in plenty +;; of comments. +;; +;; +;; *) Improve on the dired GROUP and ACCOUNT listings. +;; +;; *) Add ".." to dired FILE and GROUP listings. +;; +;; *) Support POSIX (need POSIX machine first though). +;; +;; *) Test ACCOUNT name completion and listings properly. I have the problem +;; that the only systems available to me are large ( i.e. start a listf +;; @.@.@,2 today and come back tomorrow), which makes +;; it pretty hard for me to test. +;; + +;;; Code + +(provide 'efs-mpe) +(require 'efs) + +;;; User Variables + +(defvar efs-mpe-account-completion-confirm t + "*Set to non-nil will cause a prompt to be issued before attempting ACCOUNT +name completion. For ACCOUNT name completion a LISTF @.@.@,2 is required. +This can take a very long time on large systems") + +(defvar efs-mpe-group-completion-confirm t + "*Set to non-nil will cause a prompt to be issued before attempting GROUP +name completion. For GROUP name completion a LISTF @.@.ACCOUNT,2 is required. +This can take a very long time on large accounts") + +(defvar efs-mpe-default-buildparms "" + "*If set to non empty string used to override the system default buildparms.") + +;;; Internal Variables + +(defconst efs-mpe-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Support for build parameters + +(defun efs-mpe-get-buildparms (path) + ;; Gets the mpe buildparms for PATH. PATH should be in efs syntax. + (let ((files (efs-get-files-hashtable-entry (file-name-directory + (directory-file-name path))))) + (if files + (let* ((file (efs-get-file-part path)) + (completion-ignore-case + (memq 'mpe efs-case-insensitive-host-types)) + (bpversions (all-completions (concat file ";") files))) + (cond + ((null bpversions) + efs-mpe-default-buildparms) + ((= (length bpversions) 1) + (substring (car bpversions) (length file))) + (t + (error + "efs-mpe: %s seems to have more than one set of buildparams." + path)))) + ;; return the default + efs-mpe-default-buildparms))) + +(defun efs-mpe-fix-buildparms (buildparms host user path) + "Try to assign buildparms for the file being PUT" + (or + ;; Buildparms specified with file use them. + buildparms + (efs-mpe-get-buildparms (format efs-path-format-string user host path)))) + +;;; entry points + +(efs-defun efs-fix-path mpe (path &optional reverse) + ;; Convert PATH from UNIX-ish to MPE. If REVERSE given then convert from + ;; MPE to UNIX-ish. N.B. Path does not contain HOST or USER part so the + ;; dynamic variables HOST and USER are used. + ;; Also uses the dynamic variable CMD0. + (efs-save-match-data + (if reverse + ;; This is never used as we only convert PWD (see below) output in + ;; this direction. However I will leave this here should it be + ;; required in the future. + (if (let ((case-fold-search t)) + (string-match + (concat "^\\([A-Z][A-Z0-9]*\\)" ; file + "\\(.[A-Z][A-Z0-9]*\\)" ; group + "\\(.[A-Z][A-Z0-9]*\\)$") ; account + path)) + (let (file group account) + (setq file (substring path 0 (match-end 1))) + (if (match-beginning 2) + (setq group (substring + path (1+ (match-beginning 2)) (match-end 2)))) + (if (match-beginning 3) + (setq account (substring + path (1+ (match-beginning 3)) + (match-end 3)))) + (concat (and account (concat "/" account "/")) + (and group (concat group "/")) + file)) + ;; handle PWD output + (if (let ((case-fold-search t)) + (string-match + (concat + "\\([A-Z][A-Z0-9]*\\)?" ; sessionname + ",[A-Z][A-Z0-9]*\.\\([A-Z][A-Z0-9]*\\)," ; username.account + "\\([A-Z][A-Z0-9]*\\)$") ; group + path)) + (concat "/" + (substring path (match-beginning 2) (match-end 2)) + "/" + (substring path (match-beginning 3) (match-end 3)) + "/") + (error "Invalid MPE (MPE->UNIX) filename: %s" path))) + (if (let ((case-fold-search t)) + (string-match + (concat + "^\\(/[A-Z][A-Z0-9]*/\\)" ; account + "\\([A-Z][A-Z0-9]*/\\)" ; group + "\\([A-Z][A-Z0-9]*\\)" ; file + "\\(;.*\\)?$") ; buildparms + path)) + (let ((for-put (and (boundp 'cmd0) (eq cmd0 'put))) + file group account buildparms) + (setq account (substring + path (1+ (match-beginning 1)) (1- (match-end 1)))) + (setq group (substring + path (match-beginning 2) (1- (match-end 2)))) + (setq file (substring path (match-beginning 3) (match-end 3))) + (if for-put + (setq buildparms + (efs-mpe-fix-buildparms + (and (match-beginning 4) + (substring path + (match-beginning 4) (match-end 4))) + host user path))) + (concat file + (and group (concat "." group )) + (and account (concat "." account )) + (and for-put buildparms))) + (error "Invalid MPE (UNIX->MPE) filename: *%s*" path))))) + +(efs-defun efs-fix-dir-path mpe (dir-path) + ;; Convert path from UNIX-ish to MPE ready for a DIRectory listing. MPE does + ;; not have directories as such. It does have GROUPS and ACCOUNTS, but the + ;; DIR command does not let you list just ACCOUNTs on the system or just + ;; GROUPs in the ACCOUNT - no you always get everything downwards + ;; i.e. ACCOUNTs + GROUPs + FILEs or GROUPs + FILEs or just FILEs + ;; depending on the level. + (efs-save-match-data + (message "Fixing listing %s ..." dir-path) + (cond + ;; Everything !?! might take a while. + ((string-equal dir-path "/") + (if efs-mpe-account-completion-confirm + (if (y-or-n-p "Continue with ACCOUNT name completion? ") + "@.@.@" + (error "Quit ACCOUNT name completion")) + "@.@.@")) + ;; specification starts with account + ((let ((case-fold-search t)) + (string-match + (concat + "^\\(/[A-Z][A-Z0-9]*/\\)" ; account + "\\([A-Z][A-Z0-9]*/\\)?" ; group + "\\([A-Z][A-Z0-9]*\\)?" ; file + "\\(;.*\\)?/?$") ; buildparms + dir-path)) + (let (file group account) + (setq account (substring dir-path + (1+ (match-beginning 1)) (1- (match-end 1)))) + (if (match-beginning 2) + (setq group (substring dir-path + (match-beginning 2) (1- (match-end 2)))) + (if efs-mpe-group-completion-confirm + (if (y-or-n-p "Continue with GROUP name completion? ") + (setq group "@") + (error "Quit GROUP name completion")) + (setq group "@"))) + (if (match-beginning 3) + ;;(setq file (substring dir-path + ;; (match-beginning 3) (1- (match-end 3)))) + ;; set the filename to something silly so that the DIR will fail + ;; and so force a DIR for the group instead. Either I've + ;; misunderstood something or you have to do it like this. + (setq file "~!#&*") + (setq file "@")) + (concat file "." group "." account))) + (t + (error "Invalid MPE (LISTF) filename: %s" dir-path))))) + +(defconst efs-mpe-acct-grp-line-regexp + "ACCOUNT= +\\([A-Z][A-Z0-9]*\\) +GROUP= +\\([A-Z][A-Z0-9]*\\)") +(defconst efs-mpe-file-line-regexp + (concat + "\\*? +\\([A-Z0-9]*\\) +\\([0-9]+\\)" + "\\([BW]\\) +\\([FV]\\)\\([AB]\\)\\([MCO]?\\) +\\([0-9]+\\)")) + +(efs-defun efs-parse-listing mpe + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in + ;; mpe ftp dir format. + ;; HOST is the name of the remote host. + ;; USER is the user name. + ;; DIR is the directory as a full remote path + ;; PATH is the directory in full efs-syntax + ;; SWITCHES are the switches passed to ls (not relevant for mpe) + (goto-char (point-min)) + (efs-save-match-data + ;;Make sure this is a valid listing + (if (re-search-forward "ACCOUNT= +[A-Z]+ +GROUP=" nil t) + (let (acct-tbl grp-tbl file-tbl + account group file + acct-cur grp-cur) + (goto-char (point-min)) + ;; Look for something that could be a filename. + (while (re-search-forward "^[A-Z][A-Z0-9]*" nil t) + (goto-char (match-beginning 0)) + ;; Check to see if looking at an ACCOUNT= GROUP= line. Could + ;; be a continuation (cont). line or a change in account or group + (if (looking-at efs-mpe-acct-grp-line-regexp) + (progn + (setq account (buffer-substring (match-beginning 1) + (match-end 1))) + (setq group (buffer-substring (match-beginning 2) + (match-end 2))) + ;;Check for change of account + (if (not (string-equal acct-cur account)) + (progn + ;;Create table for account names and fill with + ;; "." entry. + (if (not acct-tbl) + (progn + (setq acct-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) acct-tbl))) + (efs-put-hash-entry account '(t) acct-tbl) + ;;Store the current group table + (if grp-tbl + (progn + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/")) + grp-tbl ) + (setq grp-tbl nil))))) + ;;Check for change in group. Change in account is automatic + ;;change in group. + (if (or (not (string-equal acct-cur account)) + (not (string-equal grp-cur group))) + (progn + ;;Create table for group names and fill with + ;; "." and ".." entries. + (if (not grp-tbl) + (progn + (setq grp-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) grp-tbl) + (efs-put-hash-entry ".." '(t) grp-tbl))) + (efs-put-hash-entry group '(t) grp-tbl) + ;;Store current file table + (if file-tbl + (progn + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl) + (setq file-tbl nil))))) + ;;Set new grp-cur and acct-cur incase one or both chnaged. + (setq grp-cur group acct-cur account) + ) + ;;Looking at either a file name, or the line + ;;"FILENAME CODE --....--LOGICAL.." + ;;Save the possible filename. + (setq file (buffer-substring (point) + (progn + (skip-chars-forward "A-Z0-9") + (point)))) + ;;Make sure its a file name. + ;;"\\*?" is for files in access. + ;; File codes can be numeric as well! CdS + (if (looking-at efs-mpe-file-line-regexp) + ;;Hack out the buildparms + (let* ((code (and + (/= (match-beginning 1) (match-end 1)) + (concat ";CODE=" + (buffer-substring + (match-beginning 1) (match-end 1))))) + (length (buffer-substring (match-beginning 2) + (match-end 2))) + (eof (buffer-substring (match-beginning 7) + (match-end 7))) + (bytes (* (string-to-int eof) + (string-to-int length))) + (word-byte (buffer-substring (match-beginning 3) + (match-end 3))) + (fix-var (buffer-substring (match-beginning 4) + (match-end 4))) + (ascii-binary (buffer-substring (match-beginning 5) + (match-end 5))) + (cir-msg (and (match-beginning 6) + (buffer-substring (match-beginning 6) + (match-end 6)))) + (rec ";REC=")) + (if (string-equal word-byte "B") + (setq rec (concat rec "-")) + (setq bytes (* 2 bytes))) + (setq rec (concat rec length ",," fix-var ",")) + (if (string-equal ascii-binary "A") + (setq rec (concat rec "ASCII")) + (setq rec (concat rec "BINARY"))) + (cond ((string-equal cir-msg "M") + (setq cir-msg ";MSG")) + ((string-equal cir-msg "O") + (setq cir-msg ";CIR")) + (t + (setq cir-msg nil))) + (if (not file-tbl) + (progn + (setq file-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) file-tbl) + (efs-put-hash-entry ".." '(t) file-tbl))) + (message "Adding... %s" file) + (efs-put-hash-entry file (list nil bytes) file-tbl) + (efs-put-hash-entry (concat file rec code cir-msg) + (list nil bytes) file-tbl))) + ) ;if looking-at + (forward-line 1) + );while + ;;Check at what level the listing was done and return the + ;;corresponding table. System = acct-tbl, Account = grp-tbl, + ;;Group = file-tbl. + (if (let ((case-fold-search t)) + (string-match + "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" + dir)) + ;;group level listing, just return table of files + (if (or (match-beginning 3) (match-beginning 4)) + file-tbl + ;;account level listing, return table of groups but do not + ;;forget to store current table of files. + (if (match-beginning 2) + (progn + (if file-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl)) + grp-tbl) + ;;System level listing, return table of accounts but do not + ;;forget to store current table of groups and files + (if (match-beginning 1) + (progn + (if file-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl)) + (if grp-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/")) + grp-tbl)) + acct-tbl) + (error "Parse listing 0 path %s" path)))) + (error "Parse listing 1 path %s" path)))))) + + +(efs-defun efs-really-file-p mpe (file ent) + ;; Doesn't treat the buildparm entry as a real file entry. + (efs-save-match-data + (not (string-match ";" file)))) + +(efs-defun efs-delete-file-entry mpe (path &optional dir-p) + ;; Deletes FILE and FILE;BUILDPARMS from file hashtable. + (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-files-hashtable-entry + (file-name-directory path))) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (let ((file (efs-get-file-part path)) + (files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (if files + (efs-save-match-data + (if (string-match ";" file) + (let ((root (substring file (match-beginning 0)))) + ;; delete ROOT from hashtable + (efs-del-hash-entry root files ignore-case) + ;; delete ROOT;BUILDPARAMS from hashtable + (efs-del-hash-entry file files ignore-case)) + ;; we've specified only a root. + (let* ((root (concat file ";")) + (completion-ignore-case ignore-case) + (extensions (all-completions root files))) + ;; Get rid of FILE. + (efs-del-hash-entry file files ignore-case) + ;; Get rid of all BUILDPARAMS versions + (while extensions + ;; all-completions will return names with the right case. + ;; Don't need to ignore-case now. + (efs-del-hash-entry (car extensions) files) + (setq extensions (cdr extensions))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry mpe (path dir-p size owner + &optional modes nlinks mdtm) + ;; Deletes FILE (if present) and FILE;BUILDPARMS (if present) from hashtable + ;; then adds FILE and FILE;BUILDPARMS (if specified) to hashtable. + (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (if files + (efs-put-hash-entry (efs-get-file-part path) ent files + ignore-case))) + + (let ((files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (efs-save-match-data + (if files + (let* ((file (efs-get-file-part path)) + (root (substring file 0 (string-match ";" file)))) + (if (equal root file) + (setq file (concat file (efs-mpe-get-buildparms path)))) + ;; In case there is another entry with different buildparams, + ;; wipe it. + (efs-delete-file-entry 'mpe path nil) + (efs-put-hash-entry root ent files ignore-case) + (efs-put-hash-entry file ent files ignore-case)))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-allow-child-lookup mpe (host user dir file) + ;; Returns non-NIL if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax i.e. /foo/bar/, not + ;; /foo/bar. + + ;; Subdirs in MPE are accounts or groups. + (string-match "^/\\([^/]+/\\)?$" dir)) + +(efs-defun efs-file-type mpe (path) + ;; Returns whether to treat an efs file as a text file or not. + (let ((buildparams (efs-mpe-get-buildparms path))) + (efs-save-match-data + (let ((case-fold-search t)) + (cond + ((string-match "BINARY" buildparams) + '8-binary) + (t + 'text)))))) + +;;; Tree dired support: + +(efs-defun efs-dired-manual-move-to-filename mpe + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the MPE version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; The "\\|ACCOUNT=\\|GROUP=" bit is to take care of the hacked account and + ;; group dired listings. + (if (looking-at + ". [A-Z][A-Z0-9]*\\*? +\\([A-Z]* +[0-9]+\\|ACCOUNT=\\|GROUP=\\)") + (progn + (forward-char 2) + (point)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mpe + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the MPE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "A-Z0-9") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?*)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-ls-trim mpe () + ;; trim single file listings 1-line. + ;; This uses an evil dynamical binding of file. + (if (and (boundp 'file) (stringp file)) + (let ((f (file-name-nondirectory file))) + (or (zerop (length f)) + (progn + (goto-char (point-min)) + (if (search-forward (concat "\n" (upcase file) " ") nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))))))))) + +(efs-defun efs-dired-fixup-listing mpe (file path &optional switches wildcard) + ;; File (group) listings stay pretty much as they are group (account) and + ;; account (system) listings get realy hacked. + (efs-save-match-data + (goto-char (point-max)) + (string-match + "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" + path) + ;; group or file level listing. + (if (or (match-beginning 3) (match-beginning 4)) + ;; Hack out the continuation lines. + (while + (re-search-backward + "\n\nACCOUNT=.+GROUP=.+(CONT\\.)\n\n.*\n.*\n" nil t) + (replace-match "" nil nil)) + ;;account level listing, hack out everything apart from group names + (if (match-beginning 2) + (let ((group nil) + (grp-cur nil)) + (while + (re-search-backward + "GROUP= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" + nil t) + (setq group + (buffer-substring (match-beginning 1) (match-end 1))) + ;;Continuation header or new group + (if (string-equal grp-cur group) + (replace-match "" nil nil) + (replace-match (format "\n\n%-10sGROUP=" group) nil nil)) + (forward-line -1) + (setq grp-cur group) + (narrow-to-region (point-min) (point))) + (widen) + (goto-char (point-max)) + (insert "\n\n")) + ;;System level listing, hack out everything apart from account names + (if (match-beginning 1) + (let (account acct-cur) + (while + (re-search-backward + "^ACCOUNT= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" + nil t) + (setq account + (buffer-substring (match-beginning 1) (match-end 1))) + ;;Continuation header or new account + (if (string-equal acct-cur account) + (replace-match "" nil nil) + (replace-match (format "%-10sACCOUNT=" account) nil nil)) + (forward-line -1) + (setq acct-cur account) + (narrow-to-region (point-min) (point))) + (widen) + (goto-char (point-max)) + (insert "\n\n"))))))) + +;;; end of efs-mpe.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-ms-unix.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ms-unix.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,165 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ms-unix.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Microsoft PC FTP server in unix mode. +;; Author: Sandy Rutherford +;; Created: Thu Aug 19 08:31:15 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:37:00 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-ms-unix) +(require 'efs) + +(defconst efs-ms-unix-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-ms-unix-month-and-time-regexp + (concat + " \\([0-9]+\\) +" ; file size + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9]" + " +\\([ 012][0-9]:[0-6][0-9]\\|[12][90][0-9][0-9]\\) +")) + +;;; entry points + +(efs-defun efs-fix-path ms-unix (path &optional reverse) + ;; Convert PATH from UNIX-ish to MS-UNIX. + (if reverse + (concat "/" path) + (substring path 1))) + +(efs-defun efs-fix-dir-path ms-unix (dirpath) + ;; Convert a path from UNIX-ish to MS-UNIX for a dir listing + (if (string-equal dirpath "/") + (error "Cannot grok disk names.") + (setq dirpath (substring dirpath 1)) + (efs-save-match-data + (if (string-match "/$" dirpath) + (concat dirpath "*") + dirpath)))) + +(defmacro efs-ms-unix-parse-file-line () + ;; Extract the filename, size, and permission string from the current + ;; line of a dired-like listing. Assumes that the point is at + ;; the beginning of the line, leaves it just before the size entry. + ;; Returns a list (name size perm-string nlinks owner). + ;; If there is no file on the line, returns nil. + (` (let ((eol (save-excursion (end-of-line) (point))) + name size modes nlinks owner) + (skip-chars-forward " 0-9" eol) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) + (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-ms-unix-month-and-time-regexp eol t) + (setq name (buffer-substring (point) eol) + size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (list name size modes nlinks owner))))) + +(efs-defun efs-parse-listing ms-unix (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be output from + ;; the Microsoft FTP server in unix mode. + ;; Return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-ms-unix-month-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + size modes nlinks dir-p owner file) + (beginning-of-line) + (while (setq file (efs-ms-unix-parse-file-line)) + (setq size (nth 1 file) + modes (nth 2 file) + nlinks (nth 3 file) + owner (nth 4 file) + file (car file) + dir-p (= (string-to-char modes) ?d)) + (if (and dir-p + (string-match "/$" file)) + (setq file (substring file 0 -1))) + (efs-put-hash-entry file (list dir-p size owner modes nlinks) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Tree Dired + +;; ms-unix does not have a total line + +(efs-defun efs-dired-insert-headerline ms-unix (dir) + ;; MTS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename ms-unix + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for ms-unix. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-ms-unix-month-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ms-unix + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the ms-unix version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (eolp) + (progn + (goto-char opoint) + (if no-error + nil + (error "No file on this line"))) + (end-of-line) + (if (char-equal (preceding-char) ?/) + (forward-char -1)) + (point)))) + +;;; end of efs-ms-unix.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-mts.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mts.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,239 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mts.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MTS support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:51:29 1992 +;; Modified: Sun Nov 27 18:37:18 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-mts) +(require 'efs) + +(defconst efs-mts-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; MTS support +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; the Michigan terminal system. It should be able to automatically +;;; recognize any MTS machine. We would be grateful if you +;;; would report any failures to automatically recognize a MTS host as a bug. +;;; +;;; Filename syntax: +;;; +;;; MTS filenames are entered in a UNIX-y way. For example, if your account +;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be +;;; entered as +;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE +;;; In other words, MTS accounts are treated as UNIX directories. Of course, +;;; to access a file in another account, you must have access permission for +;;; it. If FILE were in your own account, then you could enter it in a +;;; relative path fashion as +;;; /YYYY@mtsg.ubc.ca:FILE +;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the +;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you +;;; like.) MTS filenames are always in upper case, and hence be sure to enter +;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX +;;; is. + + +(defconst efs-mts-date-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 123]?[0-9] ")) + +;;; The following two functions are entry points to this file. +;;; They are put into the appropriate alists in efs.el + +(efs-defun efs-fix-path mts (path &optional reverse) + ;; Convert PATH from UNIX-ish to MTS. + ;; If REVERSE given then convert from MTS to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) + (let (acct file) + (if (match-beginning 1) + (setq acct (substring path 0 (match-end 1)))) + (if (match-beginning 2) + (setq file (substring path + (match-beginning 2) (match-end 2)))) + (concat (and acct (concat "/" acct "/")) + file)) + (error "path %s didn't match" path)) + (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) + (concat (substring path 1 (match-end 1)) + (substring path (match-beginning 2) (match-end 2))) + ;; Let's hope that mts will recognize it anyway. + path)))) + +(efs-defun efs-fix-dir-path mts (dir-path) +;; Convert path from UNIX-ish to MTS ready for a DIRectory listing. +;; Remember that there are no directories in MTS. + (if (string-equal dir-path "/") + (error "Cannot get listing for fictitious \"/\" directory.") + (let ((dir-path (efs-fix-path 'mts dir-path))) + (cond + ((string-equal dir-path "") + "?") + ((efs-save-match-data (string-match ":$" dir-path)) + (concat dir-path "?")) + (dir-path))))) ; It's just a single file. + + +(efs-defun efs-parse-listing mts + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in + ;; mts ftp dir format. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (let ((tbl (efs-make-hashtable)) + perms) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward efs-mts-date-regexp nil t) + (beginning-of-line) + (if (looking-at "[rwed]+") + (setq perms (buffer-substring (match-beginning 0) (match-end 0))) + (setq perms nil)) + (end-of-line) + (skip-chars-backward " ") + (let ((end (point))) + (skip-chars-backward "-A-Z0-9_.!") + (efs-put-hash-entry (buffer-substring (point) end) + (list nil nil nil perms) tbl)) + (forward-line 1))) + ;; Don't need to bother with .. + (efs-put-hash-entry "." '(t) tbl) + tbl)) + +(efs-defun efs-allow-child-lookup mts (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; MTS file system is flat. Only "accounts" are subdirs. + (string-equal "/" dir)) + +(efs-defun efs-internal-file-writable-p mts (user owner modes) + (if (stringp modes) + (efs-save-match-data + (null (null (string-match "w" modes)))) + t)) ; guess + +(efs-defun efs-internal-file-readable-p mts (user owner modes) + (if (stringp modes) + (efs-save-match-data + (null (null (string-match "r" modes)))) + t)) ; guess + +;;; Tree dired support: + +;; There aren't too many systems left that use MTS. This dired support will +;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems +;; implement ftp in the same way. If not, it might be necessary to make the +;; following more flexible. + +(defconst efs-dired-mts-re-exe nil) + +(or (assq 'mts efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'mts efs-dired-mts-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-mts-re-dir nil) + +(or (assq 'mts efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'mts efs-dired-mts-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename mts + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the MTS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-mts-date-regexp eol t) + (progn + (skip-chars-forward " ") ; Eat blanks after date + (skip-chars-forward "0-9:") ; Eat time or year + (skip-chars-forward " ") ; one space before filename + (point)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mts + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the MTS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9._!") + (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard) + ;; If you're not listing your own account, MTS puts the + ;; account name in front of each filename. Scrape them off. + ;; PATH will have unix /'s on it. + ;; file-name-directory is in case of wildcards + (let ((len (length path))) + (if (> len 2) + (progn + (if (= (aref path (1- len)) ?/) + (setq path (substring path -2)) + (setq path (substring path -1))) + (goto-char (point-min)) + (while (search-forward path nil t) + (delete-region (match-beginning 0) (match-end 0))))))) + +(efs-defun efs-dired-insert-headerline mts (dir) + ;; MTS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +;;; end of efs-mts.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-mvs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mvs.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,361 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mvs.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MVS support for efs +;; Author: Sandy Rutherford +;; Created: Sat Nov 14 02:04:54 1992 +;; Modified: Sun Nov 27 18:37:54 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; -------------------------------------------------------- +;;; MVS support +;;; -------------------------------------------------------- + +(provide 'efs-mvs) +(require 'efs) + +(defconst efs-mvs-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; What's the MVS character set for valid partitioned data sets? +;; I'll guess [-A-Z0-9_$+] + +;; The top level directory in MVS contains partitioned data sets. +;; We will view these as directories. The data sets within each +;; partitioned data set will be viewed as files. +;; +;; In MVS an entry for a "sub-dir" may have the same name as a plain +;; file. This is impossible in unix, so we retain the "dots" at the +;; end of subdir names, to distinuguish. +;; i.e. FOO.BAR --> /FOO./BAR + +(efs-defun efs-send-pwd mvs (host user &optional xpwd) + ;; Broken quoting for PWD output on some MVS servers. + (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) + (line (nth 1 result)) + dir) + (and (car result) + (efs-save-match-data + (and (string-match " \"'?\\([0-9A-Z]+\\)'?\"" line) + (setq dir (substring line (match-beginning 1) + (match-end 1)))))) + (cons dir line))) + +(efs-defun efs-fix-path mvs (path &optional reverse) + ;; Convert PATH from UNIX-ish to MVS. + (efs-save-match-data + (if reverse + (let ((start 0) + (res "/")) + ;; MVS has only files, some of which are partitioned + ;; into smaller files (partitioned data sets). We will + ;; assume that path starts with a partitioned dataset. + (while (string-match "\\." path) + ;; grab the dot too, because in mvs prefixes and plain + ;; files can have the same name. + (setq res (concat res (substring path start (match-end 0)) "/") + start (match-end 0))) + (concat res (substring path start))) + (let ((start 1) + res) + (while (string-match "/" path start) + (setq res (concat res (substring path start (match-beginning 0))) + start (match-end 0))) + (concat res (substring path start)))))) + +(efs-defun efs-fix-dir-path mvs (dir-path) + ;; Convert path from UNIX-ish to MVS for a DIR listing. + (cond + ((string-equal "/" dir-path) + " ") + (t (concat (efs-fix-path 'mvs dir-path) "*")))) + +(efs-defun efs-allow-child-lookup mvs (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; MVS file system is flat. Only partitioned data sets are "subdirs". + (efs-save-match-data + (string-match "\\.$" file))) + +(efs-defun efs-parse-listing mvs (host user dir path &optional switches) + ;; Guesses the type of mvs listings. + (efs-save-match-data + (goto-char (point-min)) + (cond + ((looking-at "Volume ") + (efs-add-listing-type 'mvs:tcp host user) + (efs-parse-listing 'mvs:tcp host user dir path switches)) + + ((looking-at "[-A-Z0-9_$.+]+ ") + (efs-add-listing-type 'mvs:nih host user) + (efs-parse-listing 'mvs:nih host user dir path switches)) + + (t + ;; Since MVS works on a template system, return an empty hashtable. + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +(efs-defun efs-ls-dumb-check mvs (line host file path lsargs msg noparse + noerror nowait cont) + ;; Because of the template structure of the MVS file system, empty + ;; directories are the same as non-existent. It's better for us to treat + ;; them as empty. + (and (string-match "^550 " line) + (let ((parse (or (null noparse) (eq noparse 'parse) + (efs-parsable-switches-p lsargs t)))) + (efs-add-to-ls-cache file lsargs "\n" parse) + (if parse + (efs-set-files file (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + (if nowait + (progn + (if cont + (efs-call-cont cont "\n")) + t) + (if cont + (efs-call-cont cont "\n")) + "\n")))) + +;;;; ---------------------------------------------------- +;;;; Support for the NIH FTP server. +;;;; ---------------------------------------------------- + +(efs-defun efs-parse-listing mvs:nih + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an MVS listing + ;; Based on the listing format of the NIH server. Hope that this format + ;; is widespread. If a directory doesn't exist, get a 426 ftp error. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-syntax + (let ((tbl (efs-make-hashtable)) + (top-p (string-equal "/" dir)) + ;; assume that everything top-level is a partitioned data set + ) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward "^[-A-Z0-9_$.+]+" nil t) + (efs-put-hash-entry + (concat (buffer-substring (match-beginning 0) (match-end 0)) + (and top-p ".")) + (list top-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (or top-p (efs-put-hash-entry ".." '(t) tbl))) + tbl)) + +;;; Tree dired support + +(defconst efs-dired-mvs-re-exe + "^. [-A-Z0-9_$+]+\\.EXE " + "Regular expression to use to search for MVS executables.") + +(or (assq 'mvs:nih efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'mvs:nih efs-dired-mvs-re-exe) + efs-dired-re-exe-alist))) + +(efs-defun efs-dired-insert-headerline mvs:nih (dir) + ;; MVS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename mvs:nih + (&optional raise-error bol eol) + ;; In dired, move to the first char of the filename on this line. + ;; This is the MVS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + ;; MVS listings are pretty loose. Tough to tell when we've got a file line. + (if (and + (> (- eol bol) 2) + (progn + (forward-char 2) + (skip-chars-forward " \t") + (looking-at "[-A-Z0-9$_.+]+[ \n\r]"))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mvs:nih + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the MVS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_.+" eol) + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-get-filename mvs:nih + (&optional localp no-error-if-not-filep) + (let ((name (efs-real-dired-get-filename localp no-error-if-not-filep)) + (parsed (efs-ftp-path (dired-current-directory)))) + (if (and name (string-equal "/" (nth 2 parsed))) + (concat name ".") + name))) + +(efs-defun efs-dired-fixup-listing mvs:nih + (file path &optional switches wildcard) + ;; MVS listings have trailing spaces to 80 columns. + ;; Can lead to a mess after indentation. + (goto-char (point-min)) + (while (re-search-forward " +$" nil t) + (replace-match ""))) + +;;;; ------------------------------------------------------- +;;;; Support for the TCPFTP MVS server +;;;; ------------------------------------------------------- +;;; +;;; For TCPFTP IBM MVS V2R2.1 Does it really work? + +(efs-defun efs-parse-listing mvs:tcp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an MVS listing + ;; Based on the listing format of the NIH server. Hope that this format + ;; is widespread. If a directory doesn't exist, get a 426 ftp error. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-syntax + (efs-save-match-data + (goto-char (point-min)) + (and (looking-at "Volume ") + (let ((top-tbl (efs-make-hashtable)) + (case-fold (memq 'mvs efs-case-insensitive-host-types)) + tbl-list file dn fn tbl dir-p) + (forward-line 1) + (while (not (eobp)) + (end-of-line) + (setq file (buffer-substring (point) + (progn (skip-chars-backward "^ ") + (point))) + dn path + dir-p (string-match "\\." file)) + (efs-put-hash-entry file '(nil) top-tbl) + (if dir-p + (progn + (setq dir-p (1+ dir-p) + fn (substring file 0 dir-p)) + (efs-put-hash-entry fn '(t) top-tbl) + (while dir-p + (setq dn (efs-internal-file-name-as-directory nil + (concat dn fn)) + file (substring file dir-p) + tbl (cdr (assoc dn tbl-list))) + (or tbl (setq tbl (efs-make-hashtable) + tbl-list (cons (cons dn tbl) tbl-list))) + (efs-put-hash-entry file '(nil) tbl) + (setq dir-p (string-match "\\." file)) + (if dir-p + (progn + (setq dir-p (1+ dir-p) + fn (substring file 0 dir-p)) + (efs-put-hash-entry fn '(t) tbl)))))) + (forward-line 1)) + (while tbl-list + (efs-put-hash-entry (car (car tbl-list)) (cdr (car tbl-list)) + efs-files-hashtable case-fold) + (setq tbl-list (cdr tbl-list))) + top-tbl)))) + +;;; Tree Dired + +(efs-defun efs-dired-manual-move-to-filename mvs:tcp + (&optional raise-error bol eol) + ;; In dired, move to the first char of the filename on this line. + ;; This is the MVS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and (re-search-forward " [0-9][0-9]/[0-9][0-9]/[0-9][0-9] " eol t) + (progn + (goto-char eol) + (skip-chars-backward "-A-Z0-9$_.") + (char-equal (preceding-char) ?\ )) + (/= eol (point))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mvs:tcp + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the MVS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_.+" eol) + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-mvs.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-netrc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-netrc.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,391 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-netrc.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Parses ~/.netrc file, and does completion in /. +;; Author: Sandy Rutherford +;; Created: Fri Jan 28 19:32:47 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:38:50 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;;; ------------------------------------------------------------ +;;;; Provisions and requirements. +;;;; ------------------------------------------------------------ + +(provide 'efs-netrc) +(require 'efs-cu) +(require 'efs-ovwrt) +(require 'passwd) +(require 'efs-fnh) + +;;;; ------------------------------------------------------------ +;;;; Internal Variables +;;;; ------------------------------------------------------------ + +(defconst efs-netrc-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; Make the byte compiler happy. +(defvar dired-directory) + +;;;; ------------------------------------------------------------ +;;;; Use configuration variables. +;;;; ------------------------------------------------------------ + +(defvar efs-netrc-filename "~/.netrc" + "*File in .netrc format to search for passwords. +If you encrypt this file, name it something other than ~/.netrc. Otherwise, +ordinary FTP will bomb. + +If you have any cryption package running off of find-file-hooks +(such as crypt.el or crypt++.el), efs will use it to decrypt this file. +Encrypting this file is a good idea!") + +(defvar efs-disable-netrc-security-check nil + "*If non-nil avoid checking permissions for `efs-netrc-filename'.") + +;;;; ------------------------------------------------------------ +;;;; Host / User / Account mapping support. +;;;; ------------------------------------------------------------ + +(defun efs-set-passwd (host user passwd) + "For a given HOST and USER, set or change the associated PASSWORD." + (interactive (list (read-string "Host: ") + (read-string "User: ") + (read-passwd "Password: "))) + (efs-set-host-user-property host user 'passwd + (and passwd (efs-code-string passwd)))) + +(defun efs-set-account (host user minidisk account) + "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password. +The minidisk is only relevant for CMS. If minidisk is irrelevant, +give the null string for it. In lisp programs, give the minidisk as nil." + (interactive (efs-save-match-data + (let* ((path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (parsed (and path (efs-ftp-path path))) + (default-host (car parsed)) + (default-user (nth 1 parsed)) + (default-minidisk + (and parsed + (eq (efs-host-type default-host) 'cms) + (string-match "^/[^/]+/" (nth 2 parsed)) + (substring (nth 2 parsed) 1 + (1- (match-end 0))))) + (host (read-string "Host: " default-host)) + (user (read-string "User: " default-user)) + (minidisk + (read-string + "Minidisk (enter null string if inapplicable): " + default-minidisk)) + (account (read-passwd "Account password: "))) + (if (string-match "^ *$" minidisk) + (setq minidisk nil)) + (list host user minidisk account)))) + (and account (setq account (efs-code-string account))) + (if minidisk + (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk) + account efs-minidisk-hashtable) + (efs-set-host-user-property host user 'account account))) + +;;;; ------------------------------------------------------------ +;;;; Parsing the ~/.netrc. +;;;; ------------------------------------------------------------ + +(defconst efs-netrc-modtime nil) +;; Last modified time of the netrc file from file-attributes. + +(defun efs-netrc-next-token () + ;; Gets the next token plus it's value. + ;; Returns \(token value-1 value-2 ...\) + (skip-chars-forward " \t\n") + (while (char-equal (following-char) ?#) + (forward-line 1) + (skip-chars-forward " \t\n")) + (let ((tok (and (not (eobp)) + (downcase (buffer-substring + (point) + (progn + (skip-chars-forward "^ \n\t") + (point))))))) + (cond + ((null tok) nil) + ((string-equal tok "default") + (list tok)) + ((member tok (list "machine" "login" "password" "account")) + (list tok (efs-netrc-read-token-value))) + ((string-equal tok "minidisk") + (list tok (efs-netrc-read-token-value) + (efs-netrc-read-token-value))) + ((string-equal tok "include") + (let ((start (- (point) 7)) + (path (expand-file-name (efs-netrc-read-token-value)))) + (delete-region start (point)) + (save-excursion (insert (efs-netrc-get-include path)))) + (efs-netrc-next-token)) + ;; Deal with tokens that we skip + ((string-equal tok "macdef") + (efs-save-match-data + (search-forward "\n\n" nil 'move)) + (if (eobp) + nil + (efs-netrc-next-token))) + (t (error "efs netrc file error: Invalid token %s." tok))))) + +(defun efs-netrc-read-token-value () + ;; Read the following word as a token value. + (skip-chars-forward " \t\n") + (while (char-equal (following-char) ?#) + (forward-line 1) + (skip-chars-forward " \t\n")) + (if (eq (following-char) ?\") ;quoted token value + (prog2 + (forward-char 1) + (buffer-substring (point) + (progn (skip-chars-forward "^\"") (point))) + (forward-char 1)) + (buffer-substring (point) + (progn (skip-chars-forward "^ \n\t") (point))))) + +(defun efs-netrc-get-include (path) + ;; Returns the text of an include file. + (let ((buff (create-file-buffer path))) + (unwind-protect + (save-excursion + (set-buffer buff) + (setq buffer-file-name path + default-directory (file-name-directory path)) + (insert-file-contents path) + (normal-mode t) + (mapcar 'funcall find-file-hooks) + (setq buffer-file-name nil) + (buffer-string)) + (condition-case nil + ;; go through this rigamoroll, because who knows + ;; where an interrupt in find-file-hooks leaves us. + (save-excursion + (set-buffer buff) + (set-buffer-modified-p nil) + (passwd-kill-buffer buff)) + (error nil))))) + +(defun efs-parse-netrc-group (&optional machine) + ;; Extract the values for the tokens "machine", "login", "password", + ;; "account" and "minidisk" in the current buffer. If successful, + ;; record the information found. + (let (data login) + ;; Get a machine token. + (if (or machine (setq data (efs-netrc-next-token))) + (progn + (cond + (machine) ; noop + ((string-equal (car data) "machine") + (setq machine (nth 1 data))) + ((string-equal (car data) "default") + (setq machine 'default)) + (error + "efs netrc file error: %s" + "Token group must start with machine or default.")) + ;; Next look for a login token. + (setq data (efs-netrc-next-token)) + (cond + ((null data) + ;; This just interns in the hashtable for completion to + ;; work. The username gets set later by efs-get-user. + (if (stringp machine) (efs-set-user machine nil)) + nil) + ((string-equal (car data) "machine") + (if (stringp machine) (efs-set-user machine nil)) + (nth 1 data)) + ((string-equal (car data) "default") + 'default) + ((not (string-equal (car data) "login")) + (error "efs netrc file error: Expected login token for %s." + (if (eq machine 'default) + "default" + (format "machine %s" machine)))) + (t + (setq login (nth 1 data)) + (if (eq machine 'default) + (setq efs-default-user login) + (efs-set-user machine login) + ;; Since an explicit login entry is given, intern an entry + ;; in the efs-host-user-hashtable for completion purposes. + (efs-set-host-user-property machine login nil nil)) + (while (and (setq data (efs-netrc-next-token)) + (not (or (string-equal (car data) "machine") + (string-equal (car data) "default")))) + (cond + ((string-equal (car data) "password") + (if (eq machine 'default) + (setq efs-default-password (nth 1 data)) + (efs-set-passwd machine login (nth 1 data)))) + ((string-equal (car data) "account") + (if (eq machine 'default) + (setq efs-default-account (nth 1 data)) + (efs-set-account machine login nil (nth 1 data)))) + ((string-equal (car data) "minidisk") + (if (eq machine 'default) + (error "efs netrc file error: %s." + "Minidisk token is not allowed for default entry.") + (apply 'efs-set-account machine login (cdr data)))) + ((string-equal (car data) "login") + (error "efs netrc file error: Second login token for %s." + (if (eq machine 'default) + "default" + (format "machine %s" machine)))))) + (and data (if (string-equal (car data) "machine") + (nth 1 data) + 'default)))))))) + +(defun efs-parse-netrc () + "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'. +If the file exists and has the correct permissions then extract the +\`machine\', \`login\', \`password\', \`account\', and \`minidisk\' +information from within." + (interactive) + (and efs-netrc-filename + (let* ((file (expand-file-name efs-netrc-filename)) + ;; Set to nil to avoid an infinite recursion if the + ;; .netrc file is remote. + (efs-netrc-filename nil) + (file (efs-chase-symlinks file)) + (attr (file-attributes file)) + netrc-buffer next) + (if (or (interactive-p) ; If interactive, really do something. + (and attr ; file exists. + ;; file changed + (not (equal (nth 5 attr) efs-netrc-modtime)))) + (efs-save-match-data + (or efs-disable-netrc-security-check + (and (eq (nth 2 attr) (user-uid)) ; Same uids. + (string-match ".r..------" (nth 8 attr))) + (efs-netrc-scream-and-yell file attr)) + (unwind-protect + (save-excursion + ;; we are cheating a bit here. I'm trying to do the + ;; equivalent of find-file on the .netrc file, but + ;; then nuke it afterwards. + ;; with the bit of logic below we should be able to have + ;; encrypted .netrc files. + (set-buffer (setq netrc-buffer + (generate-new-buffer "*ftp-.netrc*"))) + (insert-file-contents file) + (setq buffer-file-name file) + (setq default-directory (file-name-directory file)) + (normal-mode t) + (mapcar 'funcall find-file-hooks) + (setq buffer-file-name nil) + (goto-char (point-min)) + (while (and (not (eobp)) + (setq next (efs-parse-netrc-group next))))) + (condition-case nil + ;; go through this rigamoroll, because we knows + ;; where an interrupt in find-file-hooks leaves us. + (save-excursion + (set-buffer netrc-buffer) + (set-buffer-modified-p nil) + (passwd-kill-buffer netrc-buffer)) + (error nil))) + (setq efs-netrc-modtime (nth 5 attr))))))) + +(defun efs-netrc-scream-and-yell (file attr) + ;; Complain about badly protected netrc files. + (let* ((bad-own (/= (nth 2 attr) (user-uid))) + (modes (nth 8 attr)) + (bad-protect (not (string-match ".r..------" modes)))) + (if (or bad-own bad-protect) + (save-window-excursion + (with-output-to-temp-buffer "*Help*" + (if bad-own + (princ + (format + "Beware that your .netrc file %s is not owned by you.\n" + file))) + (if bad-protect + (progn + (if bad-own + (princ "\nAlso,") + (princ "Beware that")) + (princ + " your .netrc file ") + (or bad-own (princ (concat file " "))) + (princ + (format + "has permissions\n %s.\n" modes)))) + (princ + "\nIf this is intentional, then setting \ +efs-disable-netrc-security-check +to t will inhibit this warning in the future.\n")) + (select-window (get-buffer-window "*Help*")) + (enlarge-window (- (count-lines (point-min) (point-max)) + (window-height) -1)) + (if (and bad-protect + (y-or-n-p (format "Set permissions on %s to 600? " file))) + (set-file-modes file 384)))))) + +;;;; ---------------------------------------------------------------- +;;;; Completion in the root directory. +;;;; ---------------------------------------------------------------- + +(defun efs-generate-root-prefixes () + "Return a list of prefixes of the form \"user@host:\". +Used when completion is done in the root directory." + (efs-parse-netrc) + (efs-save-match-data + (let (res) + (efs-map-hashtable + (function + (lambda (key value) + (if (string-match "^[^/]+\\(/\\).+$" key) + ;; efs-passwd-hashtable may have entries of the type + ;; "machine/" to indicate a password assigned to the default + ;; user for "machine". Don't use these entries for completion. + (let ((host (substring key 0 (match-beginning 1))) + (user (substring key (match-end 1)))) + (setq res (cons (list (format + efs-path-user-at-host-format + user host)) + res)))))) + efs-host-user-hashtable) + (efs-map-hashtable + (function (lambda (host user) + (setq res (cons (list (format efs-path-host-format + host)) + res)))) + efs-host-hashtable) + (if (and (null res) + (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version)) + (list nil) + res)))) + +(defun efs-root-file-name-all-completions (file dir) + ;; Generates all completions in the root directory. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-root-handler-function))) + (nconc (all-completions file (efs-generate-root-prefixes)) + (file-name-all-completions file dir)))) + + +(defun efs-root-file-name-completion (file dir) + ;; Calculates completions in the root directory to include remote hosts. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-root-handler-function))) + (try-completion + file + (nconc (efs-generate-root-prefixes) + (mapcar 'list (file-name-all-completions file "/")))))) + + +;;; end of efs-netrc.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-netware.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-netware.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,196 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-netware.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Novell Netware FTP server +;; Author: Sandy Rutherford +;; Created: Fri Oct 15 00:30:50 1993 by sandy on gauss.math.ubc.ca +;; Modified: Tue Nov 22 00:11:46 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Works for (at least) Novell NetWare v3.11. This is a DOS FTP server, +;;; however, it returns a unix-ish path format. + +(provide 'efs-netware) +(require 'efs) + +(defconst efs-netware-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Basic efs support + +(defconst efs-netware-date-regexp + (concat + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" + "Dec\\) [ 0-3][0-9] \\([0-9][0-9] \\)?[0-2][0-9]:[0-6][0-9] +")) + +(efs-defun efs-fix-path netware (path &optional reverse) + ;; Convert PATH from UNIX-ish to netware. + (efs-save-match-data + (if reverse + (cond ((string-match "^[^/][^:]*:" path) + (concat "/" path)) + ((string-match "^/" path) + path) + ((error "%s not a valid netware path." path))) + (if (string-match ":" path) + (substring path 1) + path)))) + +(efs-defun efs-fix-dir-path netware (dir-path) + ;; Convert DIR-PATH from UN*X-ish to Netware for a DIR listing. + (efs-fix-dir-path nil (efs-fix-path 'netware dir-path))) + +(defun efs-netware-bogus-listing-p (dir path) + (save-excursion + (and + (not (eobp)) + (save-excursion (forward-line 1) (eobp)) + (not (string-equal dir "/")) + (re-search-forward efs-netware-date-regexp nil t) + (search-forward "/.\n")))) + +(efs-defun efs-parse-listing netware (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; a Novell Netware FTP server (runs under DOS). + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-netware-date-regexp nil t) + (progn + (beginning-of-line) + (and (not (efs-netware-bogus-listing-p dir path)) + (let ((tbl (efs-make-hashtable)) + dir-p file size) + (while (let ((eol (save-excursion (end-of-line) (point)))) + (setq dir-p (= (following-char) ?d)) + (re-search-forward efs-netware-date-regexp eol t)) + (setq file (buffer-substring (point) + (progn (end-of-line) (point))) + size (progn + (goto-char (match-beginning 0)) + (skip-chars-backward " ") + (buffer-substring (point) + (progn + (skip-chars-backward "0-9") + (point))))) + (if (string-equal size "") + (setq size nil) + (setq size (string-to-int size))) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))))) + +;;; Sorting dir listings. + +(efs-fset 'efs-t-converter 'netware 'efs-unix-t-converter) + +;;; Dired support + +(defconst efs-dired-netware-re-exe "\\.\\(exe\\|EXE\\)$") +(or (assq 'netware efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'netware efs-dired-netware-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-netware-re-dir "^.[ \t]+d ") +(or (assq 'netware efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'netware efs-dired-netware-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename netware + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This is the Netware version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; move over marker + (if (re-search-forward efs-netware-date-regexp eol t) + (goto-char (match-end 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename netware + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the Netware version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^A-Z\n\r") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline netware (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing netware + (file path &optional switches wildcard) + ;; listings come out in random order + (let (case-fold-search) + (if (or (null switches) + ;; In case efs is handling the switches itself. + (not (string-match "t" switches))) + (progn + (goto-char (point-max)) + (if (re-search-backward efs-netware-date-regexp nil t) + (save-restriction + (forward-line 1) + (narrow-to-region (point-min) (point)) + (forward-line -1) + ;; Count how many fields + (let ((fields 0)) + (skip-chars-forward " \t") + (while (not (eolp)) + (skip-chars-forward "^ \t\n") + (skip-chars-forward " \t") + (setq fields (1+ fields))) + (sort-fields fields (point-min) (point-max))))))))) + +;;; end of efs-netware.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-nos-ve.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-nos-ve.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,209 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-nos-ve.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for NOS/VE +;; Authors: Sandy Rutherford +;; Created: Fri Aug 19 04:57:09 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:39:43 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-nos-ve) +(require 'efs) + +;;; Works for NOS/VE from CDC. NOS/VE runs on Cybers. + +;;; Thank you to Jost Krieger for +;;; providing imformation and testing. + +(defconst efs-nos-ve-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;;--------------------------------------------------------------- +;;;; NOS/VE support for efs +;;;;--------------------------------------------------------------- + +;;; A legal NOS/VE filename is of the form +;;; ........ +;;; where always starts with the char : and is followed by +;;; alphanumeric characters. Each or can be up to 31 +;;; characters. File names are case insensistive. +;;; eg. :FOO.DIR_1.DIR_2.BAR +;;; +;;; The character set consists of (single case) alphabet, the numerals, +;;; and the characters "@$_#". (Not the quotes ...) The characters +;;; "[\]{|}" will also occur in a misguided attempt at +;;; internationalization. A filename may not start with a numeral. + + +;;; entry points + +(efs-defun efs-fix-path nos-ve (path &optional reverse) + ;; Convert path from UNIX to NOS/VE. + ;; If REVERSE is non-nil, goes in the opposite direction. + (if reverse + (let* ((res (concat "." path)) + (len (length res)) + (n 0)) + (while (< n len) + (and (= (aref res n) ?.) (aset res n ?/)) + (setq n (1+ n))) + res) + (let* ((res (substring (efs-internal-directory-file-name path) 1)) + (len (length res)) + (n 0)) + (while (< n len) + (and (= (aref res n) ?/) (aset res n ?.)) + (setq n (1+ n))) + res))) + +(efs-defun efs-fix-dir-path nos-ve (dir-path) + ;; Converts DIR-PATH to NOS/VE format for a directory listing. + (efs-fix-path 'nos-ve dir-path)) + +;;; parser + +(defconst efs-nos-ve-file-line-regexp + (concat + " \\([>0-9,]+\\) bytes \\(in [0-9]+ \\(file\\|catalog\\)s?\\)?\\|" + "\\( -- empty catalog\\)\\| -- device")) + +(efs-defun efs-parse-listing nos-ve (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a NOS/VE listing. + ;; Returns a hashtable. + (goto-char (point-min)) + (efs-save-match-data + (if (and (re-search-forward efs-nos-ve-file-line-regexp + (save-excursion (end-of-line) (point)) t) + (or (match-beginning 2) (match-beginning 4))) + (let ((tbl (efs-make-hashtable)) + size dir-p file) + (forward-line 1) + (while (re-search-forward efs-nos-ve-file-line-regexp + (save-excursion (end-of-line) (point)) t) + (setq size (and (match-beginning 1) + (buffer-substring + (match-beginning 1) (match-end 1))) + dir-p (null (null (or (match-beginning 2) + (match-beginning 4))))) + (if size + (let ((start 0) + res) + (while (string-match "," size start) + (setq res (concat res (substring size start + (match-beginning 0))) + start (match-end 0))) + (setq size (string-to-int + (concat res (substring size start)))))) + (beginning-of-line) + (forward-char 2) + (setq file (buffer-substring + (point) + (progn (skip-chars-forward "^ \t\n") (point)))) + (efs-put-hash-entry file (list dir-p size) + (or tbl (setq tbl (efs-make-hashtable)))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup nos-ve (host user dir file) + ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax. + ;; i.e. /foo/bar/, not /foo/bar. + ;; Deal with dired. Anything else? + (not (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal (downcase dired-local-variables-file) + (downcase file))))) + +;;; Tree Dired + +(defconst efs-dired-nos-ve-re-exe "^.[^ \t\n]") +;; Matches no lines. Should it match something? + +(or (assq 'nos-ve efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'nos-ve efs-dired-nos-ve-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-nos-ve-re-dir " [0-9,]+ bytes in [0-9]+ file") + +(or (assq 'nos-ve efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'nos-ve efs-dired-nos-ve-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-fixup-listing nos-ve (file path &optional switches + wildcard) + ;; Need to turn the header line into something to masquerading as a file + ;; line, and need to remove the indentation. Both upset dired. + (goto-char (point-min)) + (while (search-forward "\n " nil t) + (delete-char -2)) + (goto-char (point-min)) + (if (looking-at "\\([^ \n]+ +\\)[0-9,]+ bytes in [0-9]+ file") + (progn + (delete-region (match-beginning 1) (match-end 1)) + (insert " Total of ")))) + +(defconst efs-dired-nos-ve-file-line-regexp + (concat + ".[ \t]+\\([][{}|\\\\a-z0-9@$_#]+\\) +" + "\\([>0-9,]+ bytes\\|-- \\(empty\\|device\\)\\)")) + +(efs-defun efs-dired-manual-move-to-filename nos-ve + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the NOS/VE version. + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (looking-at efs-dired-nos-ve-file-line-regexp) + (goto-char (match-beginning 1)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename nos-ve + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the NOS/VE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "_a-z0-9$@#\\\\[]{}|") ; right char set? + (if (or (= opoint (point)) (/= (following-char) ?\ )) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-nos-ve.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-ovwrt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ovwrt.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,106 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ovwrt.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Utilities for overwriting functions with new definitions. +;; Author: Andy Norman +;; Modified: Sun Nov 27 18:40:20 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Although used by efs, these utilities could be of general use to other +;;; packages too. Keeping them separate from the main efs program +;;; makes it easier for other programs to require them. + +(provide 'efs-ovwrt) + +(defconst efs-ovwrt-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-overwrite-fmt + "Note: This function has been modified to work with %s.") + +;; Make the byte compiler happy. +(defvar file-name-handler-alist) +(defvar inhibit-file-name-handlers) +(defvar inhibit-file-name-operation) + +(defun efs-safe-documentation (fun) + "A documentation function that isn't quite as fragile." + (condition-case () + (documentation fun) + (error nil))) + +(defun efs-overwrite-fn (package fun &optional newfun) + "Overwrites a function with a new definition from PACKAGE. +PACKAGE should be a string. The the function to be overwritten is FUN. +The new definition is obtained from the optional NEWFUN. If ommitted, +NEWFUN is taken to be PACKAGE-FUN. The original definition is stored in +PACKAGE-real-FUN. The original documentation is placed on the new +definition suitably augmented." + (let* ((name (symbol-name fun)) + (saved (intern (concat package "-real-" name))) + (new (or newfun (intern (concat package "-" name)))) + (nfun (symbol-function new)) + (exec-directory (if (or (equal (nth 3 command-line-args) "dump") + (equal (nth 4 command-line-args) "dump")) + "../etc/" + exec-directory))) + + (while (symbolp nfun) + (setq nfun (symbol-function nfun))) + + ;; Interpose the new function between the function symbol and the + ;; original definition of the function symbol AT TIME OF FIRST LOAD. + ;; We must only redefine the symbol-function of FUN the very first + ;; time, to avoid blowing away stuff that overloads FUN after this. + + ;; We direct the function symbol to the new function symbol + ;; rather than function definition to allow reloading of this file or + ;; redefining of the individual function (e.g., during debugging) + ;; later after some other code has been loaded on top of our stuff. + + (or (fboundp saved) + (progn + (fset saved (symbol-function fun)) + (fset fun new))) + + ;; Rewrite the doc string on the new function. This should + ;; be done every time the file is loaded (or a function is redefined), + ;; because the underlying overloaded function may have changed its doc + ;; string. + + (let* ((doc-str (efs-safe-documentation saved)) + (ndoc-str (concat doc-str (and doc-str "\n") + (format efs-overwrite-fmt package)))) + + (cond ((listp nfun) + ;; Probe to test whether function is in preloaded read-only + ;; memory, and if so make writable copy: + (condition-case nil + (setcar nfun (car nfun)) + (error + (setq nfun (copy-sequence nfun)) ; shallow copy only + (fset new nfun))) + (let ((ndoc-cdr (nthcdr 2 nfun))) + (if (stringp (car ndoc-cdr)) + ;; Replace the existing docstring. + (setcar ndoc-cdr ndoc-str) + ;; There is no docstring. Insert the overwrite msg. + (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) + (setcar ndoc-cdr (format efs-overwrite-fmt package))))) + (t + ;; it's an emacs19 compiled-code object + (let ((new-code (append nfun nil))) ; turn it into a list + (if (nthcdr 4 new-code) + (setcar (nthcdr 4 new-code) ndoc-str) + (setcdr (nthcdr 3 new-code) (cons ndoc-str nil))) + (fset new (apply 'make-byte-code new-code)))))))) + + +;;; end of efs-ovwrt.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-pc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-pc.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,980 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-pc.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: PC support for efs +;; Author: Sandy Rutherford +;; Created: Thu Mar 18 13:06:25 1993 +;; Modified: Sun Nov 27 18:40:46 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks to jrs@world.std.com (Rick Sladkey) for providing support for +;;; the Frontier Technologies Super-TCP server + +;;; Many thanks to the following people for beta testing: +;;; Mike Northam +;;; bagman@austin.ibm.com (Doug Bagley) +;;; Jens Petersen +;;; Jeff Morgenthaler + +(provide 'efs-pc) +(require 'efs) + +(defconst efs-pc-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; PC support for efs +;;;----------------------------------------------------------------- + +;;; Works for the DOS FTP servers: +;;; Novell LAN WorkPlace v4.01 (NetWare & EXOS) +;;; PC/TCP Version 2.05 pl2 FTP Server by FTP Software +;;; Microsoft FTP Server service (beta 2) +;;; NCSA DOS ftp server. +;;; Frontier Technologies super tcp server (runs under MS WINDOWS) +;;; Alun's Windows FTP daemon for Winsock, v1.8b +;;; +;;; Works for IBM OS/2 TCP/IP FTP Version 1.2 + +;;; Currently support for all of the above FTP servers are in this file. +;;; Should they live in separate files? + +;;; host and listing type hierarchy in this file +;;; +;;; dos: dos:novell, dos:ftp, dos:ncsa, dos:microsoft, dos:stcp, dos:winsock +;;; os2: + +;;; DOS and OS/2 have slightly different filename syntaxes. +;;; +;;; DOS only allows at most one extension (".") per filename. +;;; A directory name usually has the extension ".DIR" implicit, but +;;; it seems that other extensions can be used. +;;; +;;; OS/2 running the FAT file system uses the same 8.3 format for +;;; filenames as DOS, except that extensions are allowed in directory names. +;;; OS/2 running the HPFS (high performance file system allows an arbitrary +;;; number of extensions in a filename. +;;; Mostly these differences are unimportant here, except in the dos +;;; definition of efs-allow-child-lookup. + +;;;; ---------------------------------------------------- +;;;; Utility functions and macros +;;;; ---------------------------------------------------- + +(defun efs-fix-pc-path (path &optional reverse) + ;; Convert PATH from UNIX-ish to DOS or OS/2. + ;; If REVERSE do just that. + (efs-save-match-data + (if reverse + (let ((n 0) + len res) + (if (string-match "^[a-zA-Z0-9]:" path) + ;; there's a disk + (setq res (concat "\\" path)) + (setq res (copy-sequence path))) + (setq len (length res)) + (while (< n len) + (and (= (aref res n) ?\\ ) (aset res n ?/)) + (setq n (1+ n))) + res) + (let ((n 0) + len res) + (if (string-match "^/[a-zA-Z0-9]:" path) + (setq res (substring path 1)) + (setq res (copy-sequence path))) + (setq len (length res)) + (while (< n len) + (and (= (aref res n) ?/) (aset res n ?\\ )) + (setq n (1+ n))) + res)))) + +(defmacro efs-dired-pc-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the DOS and OS/2 version. It is common to all of the PC ftp + ;; servers since it depends only on the file name character set. + (` + (let ((opoint (point))) + (and selective-display + (null (, no-error)) + (eq (char-after + (1- (or (, bol) (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-zA-Z0-9.$~") + (if (= opoint (point)) + (if (, no-error) + nil + (error "No file on this line")) + (point))))) + +(defun efs-dired-pc-insert-headerline (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + + +;;;;----------------------------------------------------------- +;;;; General DOS support +;;;;----------------------------------------------------------- + +;;; Regexps to be used for host and listing-type identification. + +(defconst efs-dos:ftp-file-line-regexp + (concat + " *\\([0-9]+\\|\\) +\\([-_+=a-zA-Z0-9$~.]+\\)" + " +\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\) " + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|" + "Oct\\|Nov\\|Dec\\) [0-3][0-9] ")) + +(defconst efs-dos:microsoft-file-line-regexp + ;; matches all the way to the first char of the filename. + (concat + "[01][0-9]-[0-3][0-9]-[0-9][0-9] +[012][0-9]:[0-5][0-9][AP]M +" + "\\(\\|[0-9]+\\) +")) + +(defconst efs-dos:ncsa-file-line-regexp + "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\)[ \n]") + +(defconst efs-dos:stcp-file-line-regexp + (concat + "\\([-_+=a-zA-Z0-9$~.]+\\) +\\(\\|[0-9]+\\) " + "+[0-9][0-9]?-[0-3][0-9]-[12][90][0-9][0-9] +" + "[0-9][0-9]?:[0-5][0-9]")) + +(defconst efs-dos:winsock-date-and-size-regexp + (concat + " \\([0-9]+\\) " + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" + "Dec\\) [ 0-3][0-9] \\( [12][0-9][0-9][0-9]\\|[0-2][0-9]:[0-6][0-9]\\) +")) + +(efs-defun efs-parse-listing dos + (host user dir path &optional switches) + ;; Examine the listing, which is assumed to be either a DOS or OS/2 + ;; listing, and determine the operating system type and FTP server. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + ;; No need to check for OS/2, as it gets ID'ed by a SYST in + ;; efs-guess-host-type. + (efs-save-match-data + (cond + + ;; Check for the Microsoft server + ((re-search-forward efs-dos:microsoft-file-line-regexp nil t) + (efs-add-listing-type 'dos:microsoft host user) + (efs-parse-listing 'dos:microsoft host user dir path switches)) + + ;; Check for the Novell FTP server + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at " [0-9]+ File(s)\n")) + (efs-add-listing-type 'dos:novell host user) + (efs-parse-listing 'dos:novell host user dir path switches)) + + ;; Check for FTP software's server + ((re-search-forward efs-dos:ftp-file-line-regexp nil t) + (efs-add-listing-type 'dos:ftp host user) + (efs-parse-listing 'dos:ftp host user dir path switches)) + + ;; Check for winsock + ((re-search-forward efs-dos:winsock-date-and-size-regexp nil t) + (efs-add-listing-type 'dos:winsock host user) + (efs-parse-listing 'dos:winsock host user dir path switches)) + + ;; Check for the NCSA FTP server + ((re-search-forward efs-dos:ncsa-file-line-regexp nil t) + (efs-add-listing-type 'dos:ncsa host user) + (efs-parse-listing 'dos:ncsa host user dir path switches)) + + ;; Check for Frontier's Super-TCP server + ((re-search-forward efs-dos:stcp-file-line-regexp nil t) + (efs-add-listing-type 'dos:stcp host user) + (efs-parse-listing 'dos:stcp host user dir path switches)) + + ((string-match "^/\\([A-Za-z0-9]:/\\)?$" dir) + ;; root always exists + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)) + (t + ;; an error message? + nil)))) + +;; Some DOS servers (NCSA), return a 501 message for an empty disk. +(efs-defun efs-ls-dumb-check dos (line host file path lsargs msg noparse + noerror nowait cont) + (and (string-match "^501 " line) + (string-match "^/[A-Za-z0-9]:/?$" path) + (let ((parse (or (null noparse) (eq noparse 'parse) + (efs-parsable-switches-p lsargs t)))) + (efs-add-to-ls-cache file lsargs "\n" parse) + (if parse + (efs-set-files file (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + (if nowait + (progn + (if cont + (efs-call-cont cont "\n")) + t) + (if cont + (efs-call-cont cont "\n")) + "\n")))) + +(efs-defun efs-fix-path dos (path &optional reverse) + (efs-fix-pc-path path reverse)) + +(efs-defun efs-fix-dir-path dos (dir-path) + ;; Convert path from UNIX-ish to DOS for a DIRectory listing. + (cond ((string-match "^/\\(.:\\)?$" dir-path) + (error "Can't list DOS or OS/2 disks")) + ;; Neither DOS nor OS/2 allows us to end the name of a directory + ;; with an "\". + ;; Adding *.* to the end also allows us to distinguish plain files from + ;; directries. All DOS servers seem to understand this except + ;; Frontier Technologies' super-tcp server. + ((string-match "/$" dir-path) + (concat (efs-fix-pc-path dir-path) "*.*")) + (t (efs-fix-pc-path dir-path)))) + +(efs-defun efs-get-pwd dos (host user &optional xpwd) + ;; Parses PWD output for the current working directory. Hopefully this is + ;; DOS proof. + (let* ((result (efs-send-cmd host user (list 'quote + (if xpwd 'xpwd 'pwd)) + "Getting PWD")) + (line (nth 1 result)) + dir) + (if (car result) + (efs-save-match-data + (and (or (string-match "\"\\([^\"]*\\)\"" line) + ;; FTP software's output. They should know better... + (string-match "Current working directory is +\\([^ ]+\\)$" + line)) + (setq dir (substring line + (match-beginning 1) + (match-end 1)))))) + (cons dir line))) + +(efs-defun efs-allow-child-lookup dos (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in DOS usually don't have an extension. + (not (string-match "\\." file))) + +;;;;----------------------------------- +;;;; Support for the Novell FTP server +;;;;----------------------------------- + +(defconst efs-dos:novell-file-line-regexp + ;; Matches from the first character of the filename to the end of the date. + ;; Does not match parent directories which the server might decide + ;; to put in front of the filename. + (concat + "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\) +" + "[ 0-9][0-9]-[0-9][0-9]-[0-9][0-9] ")) + +(efs-defun efs-parse-listing dos:novell + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + file size dir-p) + (efs-save-match-data + ;; Can we check somehow if the listing is really for something + ;; that doesn't exist? + (goto-char (point-min)) + (while (re-search-forward efs-dos:novell-file-line-regexp + nil t) + (setq file (buffer-substring (match-beginning 1) + (match-end 1)) + size (buffer-substring (match-beginning 2) + (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:novell-re-exe + "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:novell efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:novell efs-dired-dos:novell-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:novell-re-dir + "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") + +(or (assq 'dos:novell efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:novell efs-dired-dos:novell-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:novell (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:novell + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; move over marker + (if (re-search-forward efs-dos:novell-file-line-regexp eol t) + (goto-char (match-beginning 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:novell + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:novell + (file path &optional switches wildcard) + ;; DOS may insert the entire directory name in front of the file name. + ;; Scrape it off. The Novell server seems to do weird things when insert + ;; the full-path, so be liberal with the hatchet. + (goto-char (point-min)) + (while (re-search-forward efs-dos:novell-file-line-regexp nil t) + (beginning-of-line) + (delete-region (point) (match-beginning 0)) + (forward-line 1)) + ;; the novell server outputs lines in seemingly random order + ;; this isn't as good as sorting switches, but at least it's not random. + (sort-fields 1 (point-min) (progn (goto-char (point-max)) + (forward-line -1) + (point)))) + +(efs-defun efs-dired-ls-trim dos:novell () + (goto-char (point-min)) + (let (case-fold-search) + (forward-line 1) + (if (looking-at " [0-9]+ File(s)\n") + (delete-region (match-beginning 0) (match-end 0))))) + + +;;;;----------------------------------------------- +;;;; PC/TCP (by FTP software) support +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:ftp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an FTP Software DOS + ;; listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + file size dir-p) + (efs-save-match-data + ;; Can we check somehow if an empty directory is really + ;; a nonexistent directory? + (goto-char (point-min)) + (goto-char (point-min)) + (while (looking-at efs-dos:ftp-file-line-regexp) + (setq file (buffer-substring (match-beginning 2) + (match-end 2)) + size (buffer-substring (match-beginning 1) + (match-end 1))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:ftp-re-exe + "^. [ \t]*[0-9]+ +[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:ftp efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:ftp efs-dired-dos:ftp-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:ftp-re-dir + "^. [ \t]* ") + +(or (assq 'dos:ftp efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:ftp efs-dired-dos:ftp-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:ftp (dir) + (efs-dired-pc-insert-headerline dir)) + +;;; Because dos:ftp listings have the file names right justified, +;;; I have reversed what -move-to-filename and -move-to-end-of-filename +;;; actually do. This shouldn't confuse dired, and should make browsing +;;; a dos:ftp listing more aesthetically pleasing. + +(efs-defun efs-dired-manual-move-to-filename dos:ftp + (&optional raise-error bol eol) + ;; In dired, move to the *last* char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos:ftp-file-line-regexp eol t) + (goto-char (match-end 2)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:ftp + (&optional no-error bol eol) + ;; Assumes point is at the *end* of filename. Really moves the + ;; point to the beginning of the filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the DOS version. It is common to all of the DOS ftp servers + ;; since it depends only on the file name character set. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-backward "-_+=a-zA-Z0-9.$~" bol) + (if (= opoint (point)) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;;;----------------------------------------------- +;;;; NCSA FTP support +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:ncsa + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let (tbl file size dir-p next) + (efs-save-match-data + (goto-char (point-min)) + (while (re-search-forward + efs-dos:ncsa-file-line-regexp + (setq next (save-excursion (forward-line 1) (point))) t) + (setq file (buffer-substring (match-beginning 1) + (match-end 1)) + size (buffer-substring (match-beginning 2) + (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) + (or tbl (setq tbl (efs-make-hashtable)))) + (goto-char next)) + ;; DOS does not put . and .. in the root directory. + (if (or tbl + ;; root always exists + (string-match "^/\\([A-Za-z0-9]:/\\)?$" dir)) + (progn + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl))) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:ncsa-re-exe + "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:ncsa efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:ncsa-re-dir + "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") + +(or (assq 'dos:ncsa efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:ncsa (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:ncsa + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward "[-_+=a-zA-Z0-9$.~]+ +\\(\\|[0-9]\\)" eol t) + (goto-char (match-beginning 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:ncsa + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:ncsa + (file path &optional switches wildcard) + ;; DOS may insert the entire directory name in front of the file name. + ;; Scrape it off. + (let (bonl) + (goto-char (point-min)) + (while (re-search-forward + efs-dos:ncsa-file-line-regexp + (setq bonl (save-excursion (forward-line 1) (point))) t) + (goto-char (match-beginning 0)) + (delete-region (point) (progn (beginning-of-line) (point))) + (goto-char bonl))) + ;; sort the buffer + (sort-fields 1 (point-min) (point-max))) + +(efs-defun efs-dired-ls-trim dos:ncsa () + (goto-char (point-min)) + (if (re-search-forward efs-dos:ncsa-file-line-regexp nil t) + (delete-region (point-min) (match-beginning 0)))) + +;;;;----------------------------------------------- +;;;; Microsoft DOS FTP support +;;;;----------------------------------------------- + +(defconst efs-dos:microsoft-valid-listing-regexp + (concat efs-dos:microsoft-file-line-regexp "\\.")) + +(efs-defun efs-parse-listing dos:microsoft + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + ;; Use the existence of a "." file as confirmation that it's really + ;; a directory listing. + (goto-char (point-min)) + (efs-save-match-data + (if (or (string-match "^/.:/$" dir) + (re-search-forward efs-dos:microsoft-valid-listing-regexp nil t)) + (let ((tbl (efs-make-hashtable)) + size dir-p) + (goto-char (point-min)) + (while (re-search-forward efs-dos:microsoft-file-line-regexp nil t) + (setq size (buffer-substring (match-beginning 1) (match-end 1))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry (buffer-substring (point) + (progn (end-of-line) + (point))) + (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:microsoft-re-exe + "^[^\n]+ +[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\)$") + +(or (assq 'dos:microsoft efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:microsoft-re-dir + "^[^\n]+ ") + +(or (assq 'dos:microsoft efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:microsoft (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:microsoft + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos:microsoft-file-line-regexp eol t) + (goto-char (match-end 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:microsoft + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +;;;;----------------------------------------------- +;;;; Frontier's Super-TCP FTP Server for Windows +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:stcp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Super-TCP FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + ;; Use the existence of a strict file line pattern as + ;; confirmation that it's really a directory listing. + (goto-char (point-min)) + (efs-save-match-data + (let ((regexp (concat "^" efs-dos:stcp-file-line-regexp))) + (if (let ((eol (save-excursion (end-of-line) (point)))) + (re-search-forward regexp eol t)) + (let ((tbl (efs-make-hashtable)) + size dir-p) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (setq size (buffer-substring (match-beginning 2) (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry (buffer-substring (match-beginning 1) + (match-end 1)) + (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:stcp-re-exe + "^[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\) ") + +(or (assq 'dos:stcp efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:stcp efs-dired-dos:stcp-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:stcp-re-dir + "^[^\n ]+ + ") + +(or (assq 'dos:stcp efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:stcp efs-dired-dos:stcp-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:stcp (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:stcp + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-dos:stcp-file-line-regexp eol t) + (goto-char (match-beginning 0)) ; returns (point) + (if raise-error + (error "No file on this line") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:stcp + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:stcp + (file path &optional switches wildcard) + ;; The Super-TCP server outputs lines in seemingly random order. + ;; This isn't as good as sorting switches, but at least it's not random. + (sort-fields 1 (point-min) (point-max))) + +;;;;---------------------------------------------------------- +;;;; Winsock DOS FTP server (Alun's FTP server) +;;;;---------------------------------------------------------- + +(efs-defun efs-parse-listing dos:winsock + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a DOS Winsock listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-dos:winsock-date-and-size-regexp nil t) + (let ((tbl (efs-make-hashtable)) + size dirp) + (while + (progn + (setq size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1))) + dirp (save-excursion + (beginning-of-line) + (skip-chars-forward " ") + (char-equal (following-char) ?d))) + (efs-put-hash-entry + (buffer-substring (point) (progn (end-of-line) (point))) + (list dirp size) tbl) + (re-search-forward efs-dos:winsock-date-and-size-regexp nil t))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(defconst efs-dired-dos:winsock-re-exe "\\.exe$") + +(or (assq 'dos:winsock efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:winsock efs-dired-dos:winsock-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:winsock-re-dir "^. +d") + +(or (assq 'dos:winsock efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:winsock efs-dired-dos:winsock-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:winsock (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:winsock + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-dos:winsock-date-and-size-regexp eol t) + (point) + (if raise-error + (error "No file on this line") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:winsock + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:winsock + (file path &optional switches wildcard) + ;; The Winsock server outputs lines in seemingly random order. + ;; This isn't as good as sorting switches, but at least it's not random. + (sort-fields 9 (point-min) (point-max))) + +;;;;----------------------------------------------------------- +;;;; OS/2 Support +;;;;----------------------------------------------------------- + +;;; OS/2 has two types of file systems, FAT and HPFS. In the FAT file system +;;; filenames are restricted to the traditional DOS 8 + 3 syntax. In the +;;; HPFS file system, filenames can have arbitrarily many extensions (.'s). +;;; As well, file lines for "." and ".." are listed for HPFS. +;;; For the FAT FS, "." and ".." lines are only listed for sudirs, it seems. +;;; Go figure... + +(defconst efs-os2-file-line-regexp + (concat + " +\\([0-9]+\\) +\\([^ ]+\\)? +[01][0-9]-[0-3][0-9]-[0-9][0-9] +" + "[0-2][0-9]:[0-6][0-9] +")) + +(efs-defun efs-fix-path os2 (path &optional reverse) + (efs-fix-pc-path path reverse)) + +(efs-defun efs-fix-dir-path os2 (dir-path) + ;; Convert path from UNIX-ish to DOS for a DIRectory listing. + (cond ((string-match "^/\\(.:\\)?$" dir-path) + (error "Can't list DOS or OS/2 disks")) + ;; Neither DOS nor OS/2 allows us to end the name of a directory + ;; with an "\". + ;; Can't just hack it off, because if the dir is C:, we'll get the + ;; default dir. + ;; Don't apend the filename wildcard to distinguish + ;; plain files from directories, because OS/2 and DOS may + ;; not agree on what the wildcard is. Also, can't then tell + ;; the difference between plain files and empty directories. + ((string-match "/$" dir-path) + (concat (efs-fix-pc-path dir-path) ".")) + (t (efs-fix-pc-path dir-path)))) + +(defconst efs-os2-dot-line-regexp + (concat efs-os2-file-line-regexp "\\.\n")) + +(efs-defun efs-parse-listing os2 + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an OS/2 listing. + ;; To make sure that it is really a directory listing and not a bogus + ;; listing of a single file, make sure that there is an entry for ".". + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (efs-save-match-data + (if (or + (string-match "^/.:/$" dir) ; FAT proofing + (progn + (goto-char (point-min)) + (re-search-forward efs-os2-dot-line-regexp nil t))) + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + (while (looking-at efs-os2-file-line-regexp) + (end-of-line) + (efs-put-hash-entry + (buffer-substring (match-end 0) (point)) + (list (and + (match-beginning 2) + (string-equal "DIR" + (buffer-substring (match-beginning 2) + (match-end 2)))) + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + tbl) + (forward-line 1)) + tbl)))) + +;;; Tree Dired + +(defconst efs-dired-os2-re-exe + "^[^\n]+\\.EXEC?$") + +(or (assq 'os2 efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'os2 efs-dired-os2-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-os2-re-dir + "^ +[0-9]+ +DIR ") + +(or (assq 'os2 efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'os2 efs-dired-os2-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename os2 + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for OS/2 + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and + (> (- eol bol) 24) + (progn + (forward-char 2) + (looking-at efs-os2-file-line-regexp))) + (goto-char (match-end 0)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename os2 + (&optional no-error bol eol) + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-insert-headerline os2 (dir) + (efs-dired-pc-insert-headerline dir)) + +;; end of efs-pc.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-plan9.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-plan9.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,51 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-plan9.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Plan 9 FTP Server +;; Author: Sandy Rutherford +;; Created: Sat Jan 22 21:26:06 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:41:05 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Works for the plan 9 server plan9.att.com. Plan 9 is an +;;; AT&T operating system that is similar to unix. + +(provide 'efs-plan9) +(require 'efs) + +(defconst efs-plan9-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(efs-defun efs-fix-dir-path plan9 (dir-path) + ;; Convert DIR-PATH from UN*X-ish to Plan 9. Does nothing actually. + ;; Avoids appending the "." that we do in unix. + dir-path) + +(efs-defun efs-allow-child-lookup plan9 (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Relies on the fact that directories can't have extensions in plan9, + ;; I think. + (and (not (and (string-equal dir "/") (string-equal file "."))) + (progn + ;; Makes sure that this is cached, before cd'ing + (efs-expand-tilde "~" 'plan9 host user) + (efs-raw-send-cd host user + (if (string-equal file ".") + (efs-internal-file-name-nondirectory + dir) + (concat dir file)) + t)))) + +;;; end of efs-plan9.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-report.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-report.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,215 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-report.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Function to report efs bugs in a usable way. +;; Author: Andy Norman, Dawn +;; Created: Tue May 18 08:34:45 1993 +;; Modified: Sun Nov 27 18:41:45 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-report) +(require 'efs) +(autoload 'reporter-submit-bug-report "reporter") +(defvar reporter-version) ; For the byte-compiler + +;;; Variables + +(defconst efs-report-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-report-salutations + ["Dear bug team:" + "Ciao bug team:" + "Salut bug team:" + "Gruss bug team:" + "To whom it may concern:" + "Fellow efs'ers:" + "Greetings earthlings:"]) + +(defvar efs-bug-address "efs-bugs@cuckoo.hpl.hp.com") + +(defconst efs-report-other-vars + ;; List of variables needed for efs-report, that aren't generated below. + '(efs-ftp-program-name + efs-ftp-program-args + efs-local-host-regexp + efs-ftp-local-host-regexp + efs-gateway-host + efs-gateway-type + reporter-version + features)) + +(defconst efs-report-avoid-vars + ;; List of variables we don't want to see. + '(efs-netrc-filename + efs-default-password + efs-default-account + efs-default-user)) + +;; Dynamically bound. Used to pass data to hooks. +(defvar efs-report-default-host nil) +(defvar efs-report-default-user nil) +(defvar efs-report-blurb nil) + +;;; Functions + +(defun efs-report-get-host-type-regexps () + "Return a list of host type regexp's which are non-nil." + (let ((list efs-host-type-alist) + ent result) + (while (setq ent (car list)) + (if (symbol-value (cdr ent)) + (setq result (cons (cdr ent) result))) + (setq list (cdr list))) + result)) + +(defun efs-report-get-versions () + ;; Return a list of efs versions variables. + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions + "efs-" obarray + (function + (lambda (sym) + (and (boundp sym) + (let ((name (symbol-name sym))) + (and (>= (length name) 8) + (string-equal (substring name -8) "-version")))))))) + 'string-lessp))) + +(defun efs-report-get-user-vars () + ;; Return a list of efs user variables. + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions "efs-" obarray 'user-variable-p)) + 'string-lessp))) + +(defun efs-report-pre-hook () + ;; efs-report-default-host, efs-report-default-user, and + ;; efs-report-blurb are dynamically bound. + (save-excursion + (let ((end (progn (mail-position-on-field "subject") (point)))) + (beginning-of-line) + (search-forward ":" end) + (delete-region (point) end) + (insert + " EFS " + (or (and (boundp 'efs-version) (string-match "/" efs-version) + (concat (substring efs-version 0 (match-beginning 0)) + " ")) + "") + "bug: "))) + (let ((host (read-string "Bug occurred for remote host: " + efs-report-default-host)) + (user (read-string "Logged in as: " + efs-report-default-user)) + buff-name) + (if (string-match "^ *$" host) (setq host nil)) + (if (string-match "^ *$" user) (setq user nil)) + (if host + (insert "\nefs believes that the host type of " host " is " + (symbol-name (efs-host-type host)) + ".\n")) + (if efs-report-blurb + (insert "\n" efs-report-blurb "\n")) + (if (and host + user + (get-buffer (setq buff-name (efs-ftp-process-buffer host user))) + (save-window-excursion + (y-or-n-p + (progn + (with-output-to-temp-buffer "*Help*" + (princ + (format + "The contents of %s +will likely very useful for identifying any bugs. + +You will be given a chance to edit out any sensitive information. +Passwords are never written into this buffer." buff-name))) + (format "Insert contents of %s? " + buff-name))))) + (let ((header-1 (concat "Contents of " buff-name ":")) + (header-2 "Please edit sensitive or irrelevant information.")) + (insert "\n" header-1 "\n" header-2 "\n") + (insert-char ?= (max (length header-1) (length header-2))) + (insert "\n\n") + (insert-buffer-substring buff-name) + (insert "\n"))))) + +(defun efs-report-post-hook () + ;; Post hook run by report-submit-bug-report. + (save-excursion + (mail-position-on-field "subject") + (let ((subj (read-string "Subject header: "))) + (if (string-equal subj "") + (subst-char-in-region + (point) + (progn + (insert + (if (or (fboundp 'yow) (load "yow" t t)) (yow) "")) + (point)) + ?\n ?\ ) + (insert subj))))) + +(defun efs-report-bug (&optional default-host default-user blurb no-confirm) + "Submit a bug report for efs." + (interactive) + (let (;; reporter-confirm-p and reporter-package-abbrev appeared once + ;; as fluid vars in reporter.el. They aren't used any longer, + ;; but we let-bind them anyway in case the user has an old version + ;; of reporter. + (reporter-confirm-p nil) + (reporter-prompt-for-summary-p nil) + (reporter-package-abbrev "efs")) + ;; Look out for old reporter versions. + (or (boundp 'reporter-version) + (setq reporter-version + "Your version of reporter is obsolete. Please upgrade.")) + (if (or no-confirm + (y-or-n-p "Do you want to submit a bug report on efs? ")) + (let ((efs-report-default-host default-host) + (efs-report-default-user default-user) + (efs-report-blurb blurb) + (vars (nconc (efs-report-get-versions) + (efs-report-get-user-vars) + efs-report-other-vars + (efs-report-get-host-type-regexps))) + (avoids efs-report-avoid-vars) + path) + (cond + ((or efs-report-default-host efs-report-default-user)) + (efs-process-host + (setq efs-report-default-host efs-process-host + efs-report-default-user efs-process-user)) + ((setq path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (let ((parsed (efs-ftp-path path))) + (setq efs-report-default-host (car parsed) + efs-report-default-user (nth 1 parsed))))) + (while avoids + (setq vars (delq (car avoids) vars)) + (setq avoids (cdr avoids))) + (reporter-submit-bug-report + efs-bug-address + "efs" + vars + (function efs-report-pre-hook) + (function efs-report-post-hook) + (aref efs-report-salutations + (% (+ (% (random) 1000) 1000) + (length efs-report-salutations)))))))) + +;;; end of efs-report.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-ti-explorer.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ti-explorer.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,371 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ti-explorer.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Explorer support for efs +;; Author: Jamie Zawinski +;; Created: Thu Dec 17 15:04:14 1992 +;; Modified: Sun Nov 27 18:42:47 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-ti-explorer) +(require 'efs) + +(defconst efs-ti-explorer-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Explorer support. +;;;; ------------------------------------------------------------ + +;;; efs support for TI Explorer Lisp Machines. +;;; Symbolics Lispms use a different syntax, but I think that the +;;; MIT and LMI Lispms use the same syntax as Explorers. + +(defconst efs-ti-explorer-filename-regexp + (let* ((excluded-chars ":;<>.#\n\r\ta-z") + (token (concat "[^" excluded-chars "]+")) + (token* (concat "[^" excluded-chars "]*"))) + (concat "\\(" token ": *" "\\)?" ; optional device + "\\([^ " excluded-chars "]" token* "\\)" + "\\(\\." token "\\)*; *" ; directory + "\\(" token* "." token* "\\|\\) *" ; name and extension + "# *-?\\([0-9]+\\|>\\)"))) ; version + +(efs-defun efs-quote-string ti-explorer (string &optional not-space) + ;; ## This is an EVIL hack. Backslash is not what Explorers use to + ;; quote magic characters, and in addition, it is *incorrect* to quote + ;; spaces between the directory and filename: they are not a part of + ;; the filename, they are ignored. Quoting them would make them be + ;; significant. + (if not-space + string + (concat "\"" string "\""))) + +(efs-defun efs-send-pwd ti-explorer (host user &optional xpwd) +;; TI-EXPLORER output from pwd's needs to be specially parsed because +;; the fullpath syntax contains spaces. + (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) + (line (nth 1 result)) + dir) + (if (car result) + (efs-save-match-data + (and (string-match "^257 " line) + (setq dir (substring line 4))))) + (cons dir line))) + +(efs-defun efs-fix-path ti-explorer (path &optional reverse) + ;; Convert PATH from UNIX-ish to Explorer. If REVERSE given then convert + ;; from Explorer to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)? *\\([^:]+:\\)? *\\([^;]*\\); *\\(.*\\)$" + path) + (let (dir file) + ;; I don't understand how "devices" work, so I'm ignoring them. + ;; (if (match-beginning 2) + ;; (setq device (substring path + ;; (match-beginning 2) + ;; (1- (match-end 2))))) + (if (match-beginning 3) + (setq dir + (substring path (match-beginning 3) (match-end 3)))) + (if (match-beginning 4) + (setq file + (substring path (match-beginning 4) (match-end 4)))) + (cond (dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + dir))) + (if (string-match "^/" dir) + (setq dir (substring dir 1)) + (setq dir (concat "/" dir))))) + (concat + ;; (and device ":") device (and device ":") + dir (and dir "/") + file)) + (error "path %s didn't match explorer syntax" path)) + (let (dir file tmp) + ;; (if (string-match "^/[^:]+:" path) + ;; (setq device (substring path 1 + ;; (1- (match-end 0))) + ;; path (substring path (match-end 0)))) + (cond ((setq tmp (file-name-directory path)) + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?/) + (vector ?.) + (vector char)))) + (substring tmp 0 -1)))) + (if (string-match "^[.]" dir) + (setq dir (substring dir 1)) + (error "explorer pathnames can't be relative") + (setq dir (concat "." dir))))) + (setq file (file-name-nondirectory path)) + (concat + ;; (and device ":") device (and device ":") + dir + (and dir ";") + file))))) + +;; (efs-fix-path-for-explorer "/PUBLIC/ZMACS/ZYMURG.LISP#1") +;; (efs-fix-path-for-explorer "PUBLIC.ZMACS;ZYMURG.LISP#1" t) + +(efs-defun efs-fix-dir-path ti-explorer (dir-path) + ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (efs-fix-path 'ti-explorer "/~/" nil)) + ((string-match "^/[-A-Z0-9_$]+:/" dir-path) + (error "Don't grok Explorer \"devices\" yet.")) + ((efs-fix-path 'ti-explorer dir-path nil)))) + +(defmacro efs-parse-ti-explorer-filename () + ;; Extract the next filename from an Explorer dired-like listing. + (` (if (re-search-forward + efs-ti-explorer-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(efs-defun efs-parse-listing ti-explorer + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an Explorer directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-ti-explorer-filename)) + ;; Explorer/Twenex listings might come out in absolute form. + (if (string-match "^[^;]*; *" file) + (setq file (substring file (match-end 0)))) + (if (string-match "\\.\\(DIRECTORY\\|directory\\)#[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match "#[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p ti-explorer (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "#[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry ti-explorer (path &optional dir-p) + (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "#[0-9]+$" file) + ;; Only delete entries with explicit version numbers. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "#[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry ti-explorer + (path dir-p size owner &optional modes nlinks mdtm) + ;; The ti-explorer version of this function needs to keep track + ;; of file versions. + (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "#[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "#[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "#" (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory ti-explorer (name) + (efs-save-match-data + (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(#[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-allow-child-lookup ti-explorer (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in EXPLORER can't have an extension (other than .DIRECTORY, + ;; which we have truncated). + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-ti-explorer-re-dir + "^. *[^;\n\r]+;[^;\n\r.]+\\.\\(DIRECTORY\\|directory\\) *#" + "Regular expression to use to search for Explorer directories.") + +(or (assq 'ti-explorer efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ti-explorer efs-dired-ti-explorer-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename ti-explorer + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Explorer version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-ti-explorer-filename-regexp eol t) + (progn + (goto-char (match-beginning 0)) + ;; Explorer listings might come out in absolute form. + (if (looking-at "[^;]*; *") + (goto-char (match-end 0)) + (point))) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ti-explorer + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Explorer version. + (let (case-fold-search) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at efs-ti-explorer-filename-regexp) + (goto-char (match-end 0)) + (if no-error + nil + (error "No file on this line"))))) + +(efs-defun efs-dired-ls-trim ti-explorer () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward efs-ti-explorer-filename-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +(efs-defun efs-internal-file-name-sans-versions ti-explorer + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "#\\([0-9]+\\|>\\)$" name) + (substring name 0 (match-beginning 0)) + name))) + +;;; ### still need to ape these from vms: +;;; efs-dired-vms-clean-directory +;;; efs-dired-vms-collect-file-versions +;;; efs-dired-vms-trample-file-versions +;;; efs-dired-vms-flag-backup-files +;;; efs-dired-vms-backup-diff + +;;; end of efs-ti-explorer.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-ti-twenex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ti-twenex.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,341 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ti-twenex.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for a TI lisp machine in Twenex emulation mode. +;; Author: Jamie Zawinski +;; Created: Thu Dec 17 15:04:14 1992 +;; Modified: Sun Nov 27 18:43:17 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-ti-twenex) +(require 'efs) + +(defconst efs-ti-twenex-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Twenex support. +;;;; ------------------------------------------------------------ +;;; Written for an explorer in ti-twenex mode. Twenex is supposed to be just +;;; MIT's name for tops-20, but an explorer emulating twenex is not the same +;;; thing. + +(defconst efs-ti-twenex-filename-regexp + (let* ((excluded-chars ":;<>.#\n\r\ta-z") + (token (concat "[^" excluded-chars "]+")) + (token* (concat "[^" excluded-chars "]*"))) + (concat "\\(" token ": *" "\\)?" ; optional device + "<\\(" token "\\)?\\(\\." token "\\)*> *" ; directory + "\\(" token* "." token* "\\|\\) *" ; name and extension + "\\(\\. *-?\\([0-9]+\\|>\\)\\)?"))) ; version + +;;; The above isn't entirely accurate, because "/" can quote any character +;;; anywhere in a pathname. + +(efs-defun efs-fix-path ti-twenex (path &optional reverse) + ;; Convert PATH from UNIX-ish to Twenex. If REVERSE given then convert + ;; from Twenex to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)? *\\([^:]+:\\)? *<\\([^>]*\\)> *\\(.*\\)$" + path) + (let (dir file) + ;; I don't understand how "devices" work, so I'm ignoring them. + ;; (if (match-beginning 2) + ;; (setq device (substring path + ;; (match-beginning 2) + ;; (1- (match-end 2))))) + (if (match-beginning 3) + (setq dir + (substring path (match-beginning 3) (match-end 3)))) + (if (match-beginning 4) + (setq file + (substring path (match-beginning 4) (match-end 4)))) + (cond (dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + dir))) + (if (string-match "^/" dir) + (setq dir (substring dir 1)) + (setq dir (concat "/" dir))))) + (concat + ;; (and device ":") device (and device ":") + dir (and dir "/") + file)) + (error "path %s didn't match ti-twenex syntax" path)) + (let (dir file tmp) + ;; (if (string-match "^/[^:]+:" path) + ;; (setq device (substring path 1 + ;; (1- (match-end 0))) + ;; path (substring path (match-end 0)))) + (cond ((setq tmp (file-name-directory path)) + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?/) + (vector ?.) + (vector char)))) + (substring tmp 0 -1)))) + (if (string-match "^[.]" dir) + (setq dir (substring dir 1)) + (setq dir (concat "." dir))))) + (setq file (file-name-nondirectory path)) + (concat + ;; (and device ":") device (and device ":") + (and dir "<") + dir + (and dir ">") + file))))) + +;; (efs-fix-path-for-twenex "/PUBLIC/ZMACS/ZYMURG.LISP.1") +;; (efs-fix-path-for-twenex "ZYMURG.LISP.1" t) + +(efs-defun efs-fix-dir-path ti-twenex (dir-path) + ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (efs-fix-path 'ti-twenex "/~/" nil)) + ((string-match "^/[-A-Z0-9_$]+:/" dir-path) + (error "Don't grok TWENEX \"devices\" yet.")) + ((efs-fix-path 'ti-twenex dir-path nil)))) + +(defmacro efs-parse-ti-twenex-filename () + ;; Extract the next filename from an Explorer dired-like listing. + (` (if (re-search-forward + efs-ti-twenex-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(efs-defun efs-parse-listing ti-twenex + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a TWENEX directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-ti-twenex-filename)) + ;; Explorer/Twenex listings might come out in absolute form. + (if (string-match "^[^>]*> *" file) + (setq file (substring file (match-end 0)))) + (if (string-match "\\.\\(DIRECTORY\\|directory\\).[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match "\\.[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p ti-twenex (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "\\.[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry ti-twenex (path &optional dir-p) + (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "\\.[0-9]+$" file) + ;; Only delete versions with explicit version numbers. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry ti-twenex + (path dir-p size owner &optional modes nlinks mdtm) + ;; The ti-twenex version of this function needs to keep track + ;; of ti-twenex's file versions. + (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "." (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory ti-twenex (name) + (efs-save-match-data + (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(\\.[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-allow-child-lookup ti-twenex (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in TI-TWENEX can't have an extension (other than .DIRECTORY, + ;; which we have truncated). + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-ti-twenex-re-dir + "^. *[^>\n\r]+>[^>\n\r.]+\\.\\(DIRECTORY\\|directory\\)\\b" + "Regular expression to use to search for TWENEX directories.") + +(or (assq 'ti-twenex efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ti-twenex efs-dired-ti-twenex-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename ti-twenex + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Twenex version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-ti-twenex-filename-regexp eol t) + (progn + (goto-char (match-beginning 0)) + ;; Twenex listings might come out in absolute form. + (if (looking-at "[^>]*> *") + (goto-char (match-end 0)) + (point))) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ti-twenex + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Explorer version. + (let (case-fold-search) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at efs-ti-twenex-filename-regexp) + (goto-char (match-end 0)) + (if no-error + nil + (error "No file on this line"))))) + +(efs-defun efs-internal-file-name-sans-versions ti-twenex + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +;;; ### still need to ape these from vms: +;;; efs-dired-vms-clean-directory +;;; efs-dired-vms-collect-file-versions +;;; efs-dired-vms-trample-file-versions +;;; efs-dired-vms-flag-backup-files +;;; efs-dired-vms-backup-diff + +;;; end of efs-ti-twenex.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-tops-20.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-tops-20.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,353 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-tops-20.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: TOPS-20 support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:52:00 1992 +;; Modified: Sun Nov 27 18:43:45 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(require 'efs) +(provide 'efs-tops-20) + +(defconst efs-tops-20-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; TOPS-20 support +;;;; ------------------------------------------------------------ + +(efs-defun efs-send-pwd tops-20 (host user &optional xpwd) + ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing + ;; this function returns the cwd in tops-20 syntax + (let* ((temp (efs-make-tmp-name host nil)) + (cmd (concat "dir * " (cdr temp))) + dir u-dir full-dir result) + (unwind-protect + (if (null (and (car (setq result (efs-raw-send-cmd + (efs-get-process host user) + cmd + "Getting TOPS-20 PWD"))) + (progn + (condition-case () + (delete-file (car temp)) (error nil)) + (car (setq result + (efs-raw-send-cmd + (efs-get-process host user) + cmd + "Trying to get TOPS-20 PWD, again.")))))) + (save-excursion + (set-buffer (get-buffer-create + efs-data-buffer-name)) + (erase-buffer) + (if (or (file-readable-p (car temp)) + (sleep-for efs-retry-time) + (file-readable-p (car temp))) + ;; Try again. + (insert-file-contents (car temp)) + (efs-error host user + (format + "list data file %s not readable" (car temp)))) + ;; get the cwd + (goto-char (point-min)) + (efs-save-match-data + (if (looking-at "[^ /:]+:<[^<>/ ]+>") + (progn + (setq dir (buffer-substring (match-beginning 0) + (match-end 0)) + u-dir (efs-internal-directory-file-name + (efs-fix-path 'tops-20 dir t)) + full-dir (format efs-path-format-string + user host u-dir)) + ;; cache the files too + (efs-set-files full-dir + (efs-parse-listing + 'tops-20 host user u-dir full-dir)) + (efs-add-to-ls-cache full-dir nil (buffer-string) t)))))) + (efs-del-tmp-name (car temp))) + (cons dir (nth 1 result)))) + +(efs-defun efs-fix-path tops-20 (path &optional reverse) + ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then + ;; do just that. + (efs-save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path) + (let ((device (and (match-beginning 1) + (substring path (match-beginning 1) + (match-end 1)))) + (dir (substring path (match-beginning 2) + (match-end 2))) + (file (substring path (1+ (match-end 2))))) + (while (string-match "\\." dir) + (setq dir (concat (substring dir 0 (match-beginning 0)) + "/" + (substring dir (match-end 0))))) + (if device + (setq dir (concat "/" device "/" dir))) + (concat dir file)) + (error "path %s didn't match tops-20 syntax" path)) + (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path) + (let ((device (and (match-beginning 1) + (substring path 1 (1- (match-end 1))))) + (dir (and (match-beginning 2) + (substring path (match-beginning 2) + (1- (match-end 2))))) + (file (substring path (match-beginning 3) + (match-end 3)))) + (if dir + (progn + (while (string-match "/" dir) + (setq dir (concat (substring dir 0 (match-beginning 0)) + "." + (substring dir (match-end 0))))) + (if device + (concat device "<" dir ">" file) + (concat "<" dir ">" file))) + (if device + (error "%s is invalid relative syntax for tops-20" path) + file))) + (error "path %s is invalid syntax for tops-20" path))))) + +(efs-defun efs-fix-dir-path tops-20 (dir-path) + ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing. + (cond ((string-equal "/" dir-path) + (error "Can't list tops-20 devices")) + ((string-match "/[^:/]+:/$" dir-path) + (error "Can't list all root directories on a tops-20 device")) + ((efs-fix-path 'tops-20 dir-path nil)))) + + +;; In tops-20 listings, the filename starts immediatley after the date regexp. + +(defconst efs-tops-20-date-regexp + (concat + " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] ")) + + +(efs-defun efs-parse-listing tops-20 + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a TOPS-20 directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$") + ;; looking at the directory name + (forward-line 1)) + (while (re-search-forward efs-tops-20-date-regexp nil t) + (setq file (buffer-substring (point) + (progn (end-of-line) (point)))) + (if (string-match "\\.DIRECTORY\\.[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + ;; sans extension + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p tops-20 (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "\\.[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry tops-20 (path &optional dir-p) + (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "\\.[0-9]+$" file) + ;; Only delete explicit versions + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry tops-20 + (path dir-p size owner &optional modes nlinks mdtm) + ;; The tops-20 version of this function needs to keep track + ;; of tops-20's file versions. + (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "." (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory tops-20 (name) + (efs-save-match-data + (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +;;; Tree Dired + +(defconst efs-dired-tops-20-re-dir + "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$") + +(or (assq 'tops-20 efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'tops-20 efs-dired-tops-20-re-dir) + efs-dired-re-dir-alist))) + + +(efs-defun efs-dired-manual-move-to-filename tops-20 + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Tops-20 version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-tops-20-date-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename tops-20 + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Tops-20 version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + ;; Is this the right character set? + (skip-chars-forward "-_A-Z0-9$.;") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-internal--file-name-sans-versions tops-20 + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +(efs-defun efs-dired-insert-headerline tops-20 (dir) + ;; TOPS-20 inserts a headerline. I would prefer the headerline + ;; to be in efs format. This version tries to + ;; be careful, because we can't count on a headerline + ;; over ftp, and we wouldn't want to delete anything + ;; important. + (save-excursion + (if (looking-at "^ wildcard ") + (forward-line 1)) + (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n") + (delete-region (point) (match-end 0))) + (insert " " (directory-file-name dir) ":\n\n"))) + +;;; end of efs-tops-20.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-vm.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vm.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,342 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vm.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Allows the VM mail reader to access folders using efs. +;; If you are looking for support for VM/CMS, see efs-cms.el. +;; Author: Sandy Rutherford +;; Created: Mon Nov 9 23:49:18 1992 by sandy on riemann +;; Modified: Sun Nov 27 18:44:07 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; If vm-get-new-mail (usually bound to "g") is given a prefix, it +;; will prompt for a folder from which to collect mail. With +;; efs-vm, this folder can be in efs syntax. As is usual +;; with VM, this folder will not be deleted. If at the folder prompt, +;; you give "/user@host:", efs-vm will collect mail from the +;; spool file on the remote machine. The spool file will be deleted if +;; the mail is successfully collected. It is not necessary for +;; movemail, nor even emacs, to be installed on the remote machine. +;; The functionality of movemail is mimicked with FTP commands. Both +;; local and remote crashboxes are used, so that mail will not be lost +;; if the FTP connection is lost. +;; +;; To use efs-vm, put (require 'efs-vm) in your .vm file. +;; +;; Works for vm 5.56 through 5.72. May not work with older versions. +;; If vm grows some file-name-handler-alist support, we should use it. +;; Actually it has. I just haven't gotten around to this yet. + +;;; Known Bugs: +;; +;; 1. efs-vm will not be able to collect mail from a spool file if +;; you do not have write permission in the spool directory. +;; I think that this precludes HP-UX. +;; I hope to do something about this. +;; +;; 2. efs-vm is as clever as at can be about spool file locking. +;; i.e. not very clever at all. At least it uses a rename command +;; to minimize the window for problems. Use POP if you want to +;; be careful. +;; + +;;; Provisions, requirements, and autoloads + +(provide 'efs-vm) +(require 'efs-cu) +(require 'efs-ovwrt) +(require 'vm) +;(require 'vm-folder) ; not provided +(if (or (not (fboundp 'vm-get-new-mail)) + (eq (car-safe (symbol-function 'vm-get-new-mail)) 'autoload)) + (load-library "vm-folder")) +(autoload 'efs-make-tmp-name "efs") +(autoload 'efs-del-tmp-name "efs") +(autoload 'efs-send-cmd "efs") +(autoload 'efs-re-read-dir "efs") +(autoload 'efs-copy-file-internal "efs") + +;;; User variables + +(defvar efs-vm-spool-files nil + "Association list of \( USER@MACHINE . SPOOLFILES \) pairs that +specify the location of the default remote spool file for MACHINE. SPOOLFILES +is a list of remote spool files.") + +(defvar efs-vm-crash-box "~/EFS.INBOX.CRASH" + "Local file where efs keeps its local crash boxes.") + +;;; Internal variables + +(defconst efs-vm-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + + +(defun efs-vm-get-new-mail (&optional arg) + "Documented as original" + (interactive "P") + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-virtual-folder) + (vm-error-if-folder-read-only) + (cond + ((null arg) + (if (not (eq major-mode 'vm-mode)) + (vm-mode)) + (if (consp (car (vm-spool-files))) + (message "Checking for new mail for %s..." buffer-file-name) + (message "Checking for new mail...")) + (let (new-messages totals-blurb) + (if (and (vm-get-spooled-mail) + (setq new-messages (vm-assimilate-new-messages t))) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb)) + (if (consp (car (vm-spool-files))) + (message "No new mail for %s" buffer-file-name) + (message "No new mail.")) + (sit-for 4) + (message "")))) + (t + (let* ((buffer-read-only nil) + (folder (read-file-name "Gather mail from folder: " + vm-folder-directory t)) + (parsed (efs-ftp-path folder)) + mcount new-messages totals-blurb) + (if parsed + (if (string-equal (nth 2 parsed) "") + ;; a spool file + (if (not (and (efs-vm-get-remote-spooled-mail folder) + (setq new-messages + (vm-assimilate-new-messages t)))) + (progn + (message + "No new mail, or mail couldn't be retrieved by ftp.") + ;; don't let this message stay up forever... + (sit-for 4) + (message "")) + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb)) + + ;; a remote folder + (let ((tmp-file (car (efs-make-tmp-name nil (car parsed)))) + (folder (expand-file-name folder))) + (unwind-protect + (progn + (efs-copy-file-internal + folder parsed tmp-file nil t nil + (format "Getting %s" folder) + ;; asynch worries me here + nil nil) + (if (and vm-check-folder-types + (not (vm-compatible-folder-p tmp-file))) + (error + "Folder %s is not the same format as this folder." + folder)) + (save-excursion + (vm-save-restriction + (widen) + (goto-char (point-max)) + (insert-file-contents tmp-file))) + (setq mcount (length vm-message-list)) + (if (setq new-messages (vm-assimilate-new-messages)) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) + '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb) + ;; The gathered messages are actually still on disk + ;; unless the user deletes the folder himself. + ;; However, users may not understand what happened if + ;; the messages go away after a "quit, no save". + (setq vm-messages-not-on-disk + (+ vm-messages-not-on-disk + (- (length vm-message-list) + mcount)))) + (message "No messages gathered.")) + (efs-del-tmp-name tmp-file))))) + + ;; local + + (if (and vm-check-folder-types + (not (vm-compatible-folder-p folder))) + (error "Folder %s is not the same format as this folder." + folder)) + (save-excursion + (vm-save-restriction + (widen) + (goto-char (point-max)) + (insert-file-contents folder))) + (setq mcount (length vm-message-list)) + (if (setq new-messages (vm-assimilate-new-messages)) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb) + ;; The gathered messages are actually still on disk + ;; unless the user deletes the folder himself. + ;; However, users may not understand what happened if + ;; the messages go away after a "quit, no save". + (setq vm-messages-not-on-disk + (+ vm-messages-not-on-disk + (- (length vm-message-list) + mcount)))) + (message "No messages gathered."))))))) + +(defun efs-vm-gobble-remote-crash-box (remote-crash-box) + (let ((remote-crash-box (expand-file-name remote-crash-box)) + (crash-box (expand-file-name efs-vm-crash-box)) + lsize) + (if (file-exists-p vm-crash-box) + (progn + ;; This should never happen, but let's make sure that we never + ;; clobber mail. + (message "Recovering messages from local crash box...") + (vm-gobble-crash-box efs-vm-crash-box) + (message "Recovering messages from local crash box... done"))) + (efs-copy-file-internal remote-crash-box (efs-ftp-path remote-crash-box) + crash-box nil nil nil + (format "Getting %s" remote-crash-box) + ;; asynch worries me here + nil nil) + ;; only delete the remote crash box if we are sure that we have everything + (if (and (setq lsize (nth 7 (file-attributes crash-box))) + (eq lsize (nth 7 (file-attributes remote-crash-box))) + (vm-compatible-folder-p crash-box)) + (progn + (vm-gobble-crash-box crash-box) + (delete-file remote-crash-box)) + ;; don't leave garbage in the local crash box + (condition-case () (delete-file crash-box) (error nil)) + (error "Problem reading remote crash box %s" remote-crash-box)))) + +(defun efs-vm-get-remote-spooled-mail (remote-path) + ;; remote-path is usually of the form /user@machine: + ;; Usually vm sets inhibit-quit to t for this. This is probably + ;; a bad idea if there is ftp activity. + ;; I don't want to assume that the remote machine has movemail. + ;; Try to mimic movemail with ftp commands as best as possible. + ;; For this to work, we need to be able to create a subdirectory + ;; in the spool directory. + (if vm-block-new-mail + (error "Can't get new mail until you save this folder.")) + (let* ((parsed (efs-ftp-path remote-path)) + (host (car parsed)) + (user (nth 1 parsed)) + (spool-files + (or (cdr (assoc (concat user "@" host) + efs-vm-spool-files)) + (list (concat "/usr/spool/mail/" user)))) + got-mail) + (while spool-files + (let* ((s-file (car spool-files)) + (spool-file (format efs-path-format-string user host s-file)) + ;; rmdir and mkdir bomb if this path ends in a /. + (c-dir (concat s-file ".CRASHBOX")) + (rc-file (concat c-dir "/CRASHBOX")) + (crash-dir (concat spool-file ".CRASHBOX/")) + (remote-crash-file (concat crash-dir "CRASHBOX")) + (crash-box (expand-file-name efs-vm-crash-box))) + (if (file-exists-p crash-box) + (progn + (message "Recovering messages from crash box...") + (vm-gobble-crash-box crash-box) + (message "Recovering messages from crash box... done") + (setq got-mail t))) + (if (let ((efs-allow-child-lookup nil)) + (file-exists-p remote-crash-file)) + (progn + (message "Recovering messages from remote crash box...") + (efs-vm-gobble-remote-crash-box remote-crash-file) + (message "Recovering messages from remote crash box... done") + (setq got-mail t))) + (if (file-exists-p crash-box) + (progn + (message "Recovering messages from crash box...") + (vm-gobble-crash-box crash-box) + (message "Recovering messages from crash box... done") + (setq got-mail t))) + (unwind-protect + (if (car + (efs-send-cmd + host user (list 'mkdir c-dir) + (format "Making crash directory %s" crash-dir))) + (progn + (efs-re-read-dir crash-dir) + (message "Unable to make crash directory %s" crash-dir) + (ding)) + (or (car + (efs-send-cmd host user (list 'rename s-file rc-file) + (format "Checking spool file %s" spool-file))) + (progn + (message "Getting new mail from %s..." spool-file) + ;; The rename above wouldn't have updated the cash. + (efs-re-read-dir crash-dir) + (efs-vm-gobble-remote-crash-box remote-crash-file) + (message "Getting new mail from %s... done" spool-file) + (setq got-mail t)))) + (condition-case nil + (efs-send-cmd + host user (list 'rmdir c-dir) + "Removing crash directory") + (error nil)))) + (setq spool-files (cdr spool-files))) + got-mail)) + +;;; Overwrite existing functions + +(efs-overwrite-fn "efs" 'vm-get-new-mail) + +;;; end of efs-vm.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-vms.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vms.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,760 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vms.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: VMS support for efs +;; Authors: Andy Norman, Joe Wells, Sandy Rutherford +;; Modified: Sun Nov 27 18:44:59 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-vms) +(require 'efs) + +(defconst efs-vms-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; VMS support. +;;;; ------------------------------------------------------------ + +;;; efs has full support for VMS hosts, including tree dired support. It +;;; should be able to automatically recognize any VMS machine. However, if it +;;; fails to do this, you can use the command efs-add-vms-host. As well, +;;; you can set the variable efs-vms-host-regexp in your .emacs file. We +;;; would be grateful if you would report any failures to automatically +;;; recognize a VMS host as a bug. +;;; +;;; Filename Syntax: +;;; +;;; For ease of *implementation*, the user enters the VMS filename syntax in a +;;; UNIX-y way. For example: +;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 +;;; would be entered as: +;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 +;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: +;;; [.CSV.POLICY]RULES.MEM +;;; you would type: +;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM +;;; +;;; A legal VMS filename is of the form: FILE.TYPE;## +;;; where FILE can be up to 39 characters +;;; TYPE can be up to 39 characters +;;; ## is a version number (an integer between 1 and 32,767) +;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ +;;; $ cannot begin a filename, and - cannot be used as the first or last +;;; character. +;;; +;;; Tips: +;;; 1. To access the latest version of file under VMS, you use the filename +;;; without the ";" and version number. You should always edit the latest +;;; version of a file. If you want to edit an earlier version, copy it to a +;;; new file first. This has nothing to do with efs, but is simply +;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is +;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you +;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find +;;; that VMS will not allow you to save the file because it will refuse to +;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and +;;; attach the buffer to this file. To get out of this situation, M-x +;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to +;;; latest version of the file. For this reason, in tree dired "f" +;;; (dired-find-file), always loads the file sans version, whereas "v", +;;; (dired-view-file), always loads the explicit version number. The +;;; reasoning being that it reasonable to view old versions of a file, but +;;; not to edit them. +;;; 2. EMACS has a feature in which it does environment variable substitution +;;; in filenames. Therefore, to enter a $ in a filename, you must quote it +;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the +;;; $'s in the default directory when it writes it in the minibuffer. You +;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug +;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 +;;; or newer), you will not have this problem. + + +;; Because some VMS ftp servers convert filenames to lower case +;; we allow a-z in the filename regexp. + +(defconst efs-vms-filename-regexp + "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+") +;; Regular expression to match for a valid VMS file name in Dired buffer. + +(defvar efs-vms-month-alist + '(("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 efs-vms-date-regexp + (concat + "\\([0-3]?[0-9]\\)-" + "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|" + "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-" + "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)" + "\\(:[0-5][0-9]\\)?\\)? ")) + + +;;; The following two functions are entry points to this file. +;;; They are defined as efs-autoloads in efs.el + +(efs-defun efs-fix-path vms (path &optional reverse) + ;; Convert PATH from UNIX-ish to VMS. + ;; If REVERSE given then convert from VMS to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path) + (let (drive dir file) + (if (match-beginning 1) + (setq drive (substring path + (match-beginning 1) + (match-end 1)))) + (if (match-beginning 2) + (setq dir + (substring path (match-beginning 2) (match-end 2)))) + (if (match-beginning 3) + (setq file + (substring path (match-beginning 3) (match-end 3)))) + (and dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + (substring dir 1 -1))))) + (concat (and drive + (concat "/" drive "/")) + dir (and dir "/") + file)) + (error "path %s didn't match" path)) + (let (drive dir file) + (if (string-match "^/[^:/]+:/" path) + (setq drive (substring path 1 (1- (match-end 0))) + path (substring path (1- (match-end 0))))) + (setq dir (file-name-directory path) + file (efs-internal-file-name-nondirectory path)) + (if dir + (let ((len (1- (length dir))) + (n 0)) + (if (<= len 0) + (setq dir nil) + (while (<= n len) + (and (char-equal (aref dir n) ?/) + (cond + ((zerop n) (aset dir n ?\[)) + ((= n len) (aset dir n ?\])) + (t (aset dir n ?.)))) + (setq n (1+ n)))))) + (concat drive dir file))))) + +;; It is important that this function barf for directories for which we know +;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". +;; This is because it saves an unnecessary FTP error, or possibly the listing +;; might succeed, but give erroneous info. This last case is particularly +;; likely for OS's (like MTS) for which we need to use a wildcard in order +;; to list a directory. + +(efs-defun efs-fix-dir-path vms (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + ;; Should there be entries for .. -> [-] and . -> [] below. Don't + ;; think so, because expand-filename should have already short-circuited + ;; them. + (cond ((string-equal dir-path "/") + (error "Cannot get listing for fictitious \"/\" directory.")) + ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) + (error "Cannot get listing for device.")) + ((efs-fix-path 'vms dir-path)))) + +;; These parsing functions are as general as possible because the syntax +;; of ftp listings from VMS hosts is a bit erratic. What saves us is that +;; the VMS filename syntax is so rigid. If they bomb on a listing in the +;; standard VMS Multinet format, then this is a bug. If they bomb on a listing +;; from vms.weird.net, then too bad. + +(defmacro efs-parse-vms-filename () + "Extract the next filename from a VMS dired-like listing." + (` (if (re-search-forward + efs-vms-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(defun efs-parse-vms-listing () + ;; Parse the current buffer which is assumed to be a VMS DIR + ;; listing (either a short (NLIST) or long listing). + ;; Assumes that point is at the beginning of the buffer. + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-vms-filename)) + (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match ";[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + ;; Would like to look for a "Total" line, or a "Directory" line to + ;; make sure that the listing isn't complete garbage before putting + ;; in "." and "..", but we can't even count on all VAX's giving us + ;; either of these. + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-parse-listing vms + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a VMS FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + ;; check for a DIR/FULL monstrosity + (if (search-forward "\nSize:" nil t) + (progn + (efs-add-listing-type 'vms:full host user) + ;; This will cause the buffer to be refilled with an NLIST + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (goto-char (point-min)) + (efs-parse-vms-listing)) + (efs-parse-vms-listing)))) + + +;;;; Sorting of listings + +(efs-defun efs-t-converter vms (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-vms-filename-regexp nil t) + (let (list-start start end list) + (beginning-of-line) + (setq list-start (point)) + (while (and (looking-at efs-vms-filename-regexp) + (progn + (setq start (point)) + (goto-char (match-end 0)) + (forward-line (if (eolp) 2 1)) + (setq end (point)) + (goto-char (match-end 0)) + (re-search-forward efs-vms-date-regexp nil t))) + (setq list + (cons + (cons + (nconc + (list (string-to-int (buffer-substring + (match-beginning 3) + (match-end 3))) ; year + (cdr (assoc + (buffer-substring (match-beginning 2) + (match-end 2)) + efs-vms-month-alist)) ; month + (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1)))) ;day + (if (match-beginning 4) + (list + (string-to-int (buffer-substring + (match-beginning 5) + (match-end 5))) ; hour + (string-to-int (buffer-substring + (match-beginning 6) + (match-end 6))) ; minute + (if (match-beginning 7) + (string-to-int (buffer-substring + (1+ (match-beginning 7)) + (match-end 7))) ; seconds + 0)) + (list 0 0 0))) + (buffer-substring start end)) + list)) + (goto-char end)) + (if list + (progn + (setq list + (mapcar 'cdr + (sort list 'efs-vms-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list))) + t))))) + +(defun efs-vms-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minute1 (nth 4 data1)) + (minute2 (nth 4 data2))) + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (or (> minute1 minute2) + (and (= minute1 minute2) + (or (> (nth 5 data1) + (nth 5 data2))) + )))))))))))) + + +(efs-defun efs-X-converter vms (&optional regexp reverse) + ;; Sorts by extension + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-vms-filename-regexp nil t) + (let (list-start start list) + (beginning-of-line) + (setq list-start (point)) + (while (looking-at efs-vms-filename-regexp) + (setq start (point)) + (goto-char (match-end 0)) + (forward-line (if (eolp) 2 1)) + (setq list + (cons + (cons (buffer-substring (match-beginning 2) + (match-end 2)) + (buffer-substring start (point))) + list))) + (setq list + (mapcar 'cdr + (sort list + (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + (delete-region list-start (point)) + (apply 'insert list) + t))))) + +;; This version only deletes file entries which have +;; explicit version numbers, because that is all VMS allows. + +(efs-defun efs-delete-file-entry vms (path &optional dir-p) + (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match ";[0-9]+$" file) + ;; In VMS you can't delete a file without an explicit + ;; version number, or wild-card (e.g. FOO;*) + ;; For now, we give up on wildcards. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match ";[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry vms (path dir-p size owner + &optional modes nlinks mdtm) + ;; The vms version of this function needs to keep track + ;; of vms's file versions. + (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + ;; In VMS files must have an extension. If there isn't + ;; one, it will be added. + (or (string-match "^[^;]*\\." file) + (if (string-match ";" file) + (setq file (concat + (substring file 0 (match-beginning 0)) + ".;" + (substring file (match-end 0)))) + (setq file (concat file ".")))) + (if (string-match ";[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match ";[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file ";" (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-really-file-p vms (file ent) + ;; Returns whether the hash entry FILE with entry ENT is a real file. + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match ";" file)))) + +(efs-defun efs-internal-file-name-as-directory vms (name) + (efs-save-match-data + (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-remote-directory-file-name vms (dir) + ;; Returns the VMS filename in unix directory syntax for directory DIR. + ;; This is something like /FM/SANDY/FOOBAR.DIR;1 + (efs-save-match-data + (setq dir (directory-file-name dir)) + (concat dir + (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir))) + ".dir;1" + ".DIR;1")))) + +(efs-defun efs-allow-child-lookup vms (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in VMS can't have an extension (other than .DIR, which we + ;; have truncated). + (not (or (string-match "\\." file) + (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal dired-local-variables-file file))))) + +;;; Tree dired support: + +;; For this code I have borrowed liberally from Sebastian Kremer's +;; dired-vms.el + + +;; These regexps must be anchored to beginning of line. +;; Beware that the ftpd may put the device in front of the filename. + +(defconst efs-dired-vms-re-exe + "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]") + +(or (assq 'vms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vms efs-dired-vms-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-vms-re-dir + "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]") + +(or (assq 'vms efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vms efs-dired-vms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline vms (dir) + ;; VMS inserts a headerline. I would prefer the headerline + ;; to be in efs format. This version tries to + ;; be careful, because we can't count on a headerline + ;; over ftp, and we wouldn't want to delete anything + ;; important. + (save-excursion + (if (looking-at "^ \\(list \\)?wildcard ") + (forward-line 1)) + ;; This is really aggressive. Too aggressive? + (let ((start (point))) + (skip-chars-forward " \t\n") + (if (looking-at efs-vms-filename-regexp) + (beginning-of-line) + (forward-line 1) + (skip-chars-forward " \t\n") + (beginning-of-line)) + (delete-region start (point))) + (insert " \n")) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard) + ;; Some vms machines list the entire path. Scrape this off. + (setq path (efs-fix-path + 'vms + ;; Need the file-name-directory, in case of widcards. + ;; Note that path is a `local' path rel. the remote host. + ;; Lose on wildcards in parent dirs. Fix if somebody complains. + (let (file-name-handler-alist) + (file-name-directory path)))) + ;; Some machines put a Node name down too. + (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?" + (regexp-quote path)))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Now need to deal with continuation lines. + (goto-char (point-min)) + (let (col start end) + (while (re-search-forward + ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t) + (setq start (match-beginning 1) + end (match-end 1)) + ;; guess at the column dimensions + (or col + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + (concat efs-vms-filename-regexp + "[ \t]+[^ \t\n\r]") nil t) + (setq col (- (goto-char (match-end 0)) + (progn (beginning-of-line) (point)) + 1)) + (setq col 0)))) + ;; join cont. lines. + (delete-region start end) + (goto-char start) + (insert-char ? (max (- col (current-column)) 2)))) + ;; Some vms dir listings put a triple null line before the total line. + (goto-char (point-min)) + (skip-chars-forward "\n") + (if (search-forward "\n\n\n" nil t) + (delete-char -1))) + +(efs-defun efs-dired-manual-move-to-filename vms + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the VMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-vms-filename-regexp eol t) + (goto-char (match-beginning 0)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vms + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the VMS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_A-Za-z0-9$.;") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?\t ?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-ls-trim vms () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward efs-vms-filename-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +(efs-defun efs-internal-file-name-sans-versions vms + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match ";[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +(efs-defun efs-dired-collect-file-versions vms () + ;; If it looks like file FN has versions, return a list of the versions. + ;; That is a list of strings which are file names. + ;; The caller may want to flag some of these files for deletion. + (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types)) + result) + (dired-map-dired-file-lines + (function + (lambda (fn) + (if (string-match ";[0-9]+$" fn) + (let* ((base-fn (substring fn 0 (match-beginning 0))) + (base-version (file-name-nondirectory + (substring fn 0 (1+ (match-beginning 0))))) + (bv-length (length base-version)) + (possibilities (and + (null (assoc base-fn result)) + (file-name-all-completions + base-version + (file-name-directory fn))))) + (if possibilities + (setq result + (cons (cons base-fn + ;; code this explicitly + ;; using backup-extract-version has a + ;; lot of function-call overhead. + (mapcar (function + (lambda (fn) + (string-to-int + (substring fn bv-length)))) + possibilities)) result)))))))) + result)) + +(efs-defun efs-dired-flag-backup-files vms (&optional unflag-p) + (interactive "P") + (let ((dired-kept-versions 1) + (kept-old-versions 0) + marker msg) + (if unflag-p + (setq marker ?\040 msg "Unflagging old versions") + (setq marker dired-del-marker msg "Purging old versions")) + (dired-clean-directory 1 marker msg))) + +(efs-defun efs-internal-diff-latest-backup-file vms (fn) + ;; For FILE;#, returns the filename FILE;N, where N + ;; is the largest number less than #, for which this file exists. + ;; Returns nil if none found. + (efs-save-match-data + (and (string-match ";[0-9]+$" fn) + (let ((base (substring fn 0 (1+ (match-beginning 0)))) + (num (1- (string-to-int (substring fn + (1+ (match-beginning 0)))))) + found file) + (while (and (setq found (> num 0)) + (not (file-exists-p + (setq file + (concat base (int-to-string num)))))) + (setq num (1- num))) + (and found file))))) + +;;;;-------------------------------------------------------------- +;;;; Support for VMS DIR/FULL listings. (listing type vms:full) +;;;;-------------------------------------------------------------- + +(efs-defun efs-parse-listing vms:full + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a VMS FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (efs-parse-vms-listing))) + +;;; Tree Dired + +(or (assq 'vms:full efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vms:full efs-dired-vms-re-exe) + efs-dired-re-exe-alist))) + +(or (assq 'vms:full efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vms:full efs-dired-vms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline vms:full (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename vms:full + (&optional raise-error bol eol) + (let ((efs-dired-listing-type 'vms)) + (efs-dired-manual-move-to-filename raise-error bol eol))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vms:full + (&optional no-error bol eol) + (let ((efs-dired-listing-type 'vms)) + (efs-dired-manual-move-to-end-of-filename no-error bol eol))) + +;;; end of efs-vms.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-vos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vos.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,285 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vos.el +;; Description: VOS support for efs +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Author: Sandy Rutherford +;; Created: Sat Apr 3 03:05:00 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:45:24 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; The original ange-ftp VOS support was written by Joe Wells + +;;; Thank you to Jim Franklin for providing +;;; information on the VOS operating system. + +(provide 'efs-vos) +(require 'efs) + +(defconst efs-vos-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;;--------------------------------------------------------------- +;;;; VOS support for efs +;;;;--------------------------------------------------------------- + +;;; A legal VOS pathname is of the form: +;;; %systemname#diskname>dirname>dirname>dir-or-filename +;;; +;;; Each of systemname, diskname, dirname, dir-or-filename can be +;;; at most 32 characters. +;;; Valid characters are all alpha, upper and lower case, all digits, +;;; plus: @[]\^`{|}~"$+,-./:_ +;;; restrictions: name cannot begin with hyphen (-) or period (.) +;;; name must not end with a period (.) +;;; name must not contain two adjacent periods (.) +;;; +;;; Invalid characters are: +;;; non-printing control characters +;;; SPACE and DEL +;;; !#%&'()*;<=>? +;;; all other ascii chars +;;; +;;; The full pathname must be less than or equal to 256 characters. +;;; VOS pathnames are CASE-SENSITIVE. +;;; The may be a directory depth limitation of 10 (newer versions may have +;;; eliminated this). + +;;; entry points + +(efs-defun efs-fix-path vos (path &optional reverse) + ;; Convert PATH from UNIX-ish to VOS. + ;; If REVERSE given then convert from VOS to UNIX-ish. + ;; Does crude checking for valid path syntax, but is by no means exhaustive. + (efs-save-match-data + (if reverse + (if (string-match "^\\(\\(%[^#>%]+\\)?#[^>#%]+\\)?>[^>#%]" path) + (let ((marker (1- (match-end 0))) + (result "/") + system drive) + (if (match-beginning 1) + (if (match-beginning 2) + (setq system (substring path 1 (match-end 2)) + drive (substring path (1+ (match-end 2)) + (match-end 1))) + (setq drive (substring 1 (match-end 1))))) + (while (string-match ">" path marker) + (setq result (concat result + (substring path marker + (match-beginning 0)) + "/") + marker (match-end 0))) + (if drive + (if system + (concat "/" system "/" drive result + (substring path marker)) + (concat "/" drive result (substring path marker))) + (concat result (substring path marker)))) + (error "Invalid VOS pathname %s" path)) + (if (string-match "^/\\([^/]+\\)/\\([^/]+\\)/[^/]" path) + (let ((marker (1- (match-end 0))) + (result (concat "%" + (substring path + (match-beginning 1) + (match-end 1)) + "#" + (substring path + (match-beginning 2) + (match-end 2)) + ">"))) + ;; I'm guessing that VOS doesn't have a directory syntax. + (setq path (efs-internal-directory-file-name path)) + (while (string-match "/" path marker) + (setq result + (concat result + (substring path marker + (match-beginning 0)) + ">") + marker (match-end 0))) + (concat result (substring path marker))) + (error "Cannot convert path %s to VOS." path))))) + +(efs-defun efs-fix-dir-path vos (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (error "Cannot gork VOS system names")) + ((string-match "^/[^/]/$" dir-path) + (error "Cannot grok VOS devices")) + ((efs-fix-path 'vos dir-path)))) + +(defconst efs-vos-date-and-time-regexp + (concat + "\\(^\\| \\)" ; For links, this must match at the beginning of the line. + "[678901][0-9]-[01][0-9]-[0-3][0-9] [012][0-9]:[0-6][0-9]:[0-6][0-9] ")) +;; Regexp to match a VOS file line. The end of the regexp must correspond +;; to the start of the filename. + +(defmacro efs-vos-parse-filename () + ;; Return the VOS filename on the current line of a listing. + ;; Assumes that the point is at the beginning of the line. + ;; Return nil if no filename is found. + (` (let ((eol (save-excursion (end-of-line) (point)))) + (and (re-search-forward efs-vos-date-and-time-regexp eol t) + (buffer-substring (point) eol))))) + +(efs-defun efs-parse-listing vos + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in MultiNet FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (let (tbl file) + ;; Look file files. + (if (search-forward "\nFiles: " nil t) + (progn + (setq tbl (efs-make-hashtable)) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (efs-put-hash-entry file '(nil) tbl) + (forward-line 1)))) + ;; Look for directories. + (if (search-forward "\nDirs: " nil t) + (progn + (or tbl (setq tbl (efs-make-hashtable))) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (efs-put-hash-entry file '(t) tbl) + (forward-line 1)))) + ;; Look for links + (if (search-forward "\nLinks: " nil t) + (let (link) + (or tbl (setq tbl (efs-make-hashtable))) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (if (string-match " -> \\([^ ]+\\)" file) + ;; VOS puts a trailing blank after the name of a symlink + ;; target. Go figure... + (setq link (substring file (match-beginning 1) (match-end 1)) + file (substring file 0 (match-beginning 0))) + (setq link "")) ; weird? + (efs-put-hash-entry file (list link) tbl) + (forward-line 1)))) + ;; This returns nil if no headings for files, dirs, or links + ;; are found. In this case, we're assuming that it isn't a valid + ;; listing. + (if tbl + (progn + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl))) + tbl))) + +(efs-defun efs-allow-child-lookup vos (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Directoried don't have a size. + (string-match ": not a file\\.$" + (cdr (efs-send-size host user (concat dir file))))) + +;;; Tree Dired Support + +(defconst efs-dired-vos-re-exe + "^. +e ") + +(or (assq 'vos efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vos efs-dired-vos-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-vos-re-dir + "^. +[nsm] +[0-9]+ +[678901][0-9]-") + +(or (assq 'vos efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vos efs-dired-vos-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename vos + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line, where + ;; line can be delimited by either \r or \n. + ;; Returns (point) or nil if raise-error is nil and there is no + ;; filename on this line. In the later case, leaves the point at the + ;; beginning of the line. + ;; This version is for VOS. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-vos-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vos + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the VOS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-a-zA-Z0-9@[]\\^`{|}~\"$+,./:_") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-fixup-listing vos (file path &optional switches wildcard) + ;; VOS listing contain some empty lines, which is inconvenient for dired. + (goto-char (point-min)) + (skip-chars-forward "\n") + (delete-region (point-min) (point)) + (while (search-forward "\n\n" nil t) + (forward-char -2) + (delete-char 1))) + +(efs-defun efs-dired-ls-trim vos () + ;; Trims VOS dir listings for single files, so that they are exactly one line + ;; long. + (goto-char (point-min)) + (let (case-fold-search) + (re-search-forward efs-vos-date-and-time-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +;;; end of efs-vos.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs-x19.15.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-x19.15.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,69 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-x19.15.el +;; Release: $efs release: 1.14 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for XEmacs, versions 19.15, and later. +;; Author: Sandy Rutherford +;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 +;; Modified: by Mike Sperber +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-x19\.15) +(require 'efs-cu) +(require 'default-dir) +(require 'efs-ovwrt) + +(defconst efs-x19\.15-version + (concat (substring "$efs release: 1.14 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Functions requiring special defs. for these XEmacs versions. + +(defun efs-abbreviate-file-name (filename &optional hack-homedir) + ;; XEmacs version of abbreviate-file-name for remote files. + (let (file-name-handler-alist) + (if (and hack-homedir (efs-ftp-path filename)) + ;; Do replacements from directory-abbrev-alist + (apply 'efs-unexpand-parsed-filename + (efs-ftp-path (abbreviate-file-name filename nil))) + (abbreviate-file-name filename hack-homedir)))) + +(defun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because XEmacs and FSF do this differently. + (setq buffer-file-name filename) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (compute-buffer-file-truename) + (setq buffer-file-truename filename))) + +;; Only XEmacs has this function. Why do we need both this and +;; set-visited-file-modtime? + +(defun efs-set-buffer-modtime (buffer &optional time) + ;; For buffers visiting remote files, set the buffer modtime. + (or time + (progn + (setq time + (let* ((file (save-excursion + (set-buffer buffer) buffer-file-name)) + (parsed (efs-ftp-path file))) + (efs-get-file-mdtm (car parsed) (nth 1 parsed) + (nth 2 parsed) file))) + (if time + (setq time (cons (car time) (nth 1 time))) + (setq time '(0 . 0))))) + (let (file-name-handler-alist) + (set-buffer-modtime buffer time))) + +;;; For the file-name-handler-alist + +(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) + +;;; end of efs-x19.15.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/efs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,10845 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Transparent FTP support for the original GNU Emacs +;; from FSF and Lucid Emacs +;; Authors: Andy Norman , +;; Sandy Rutherford +;; Created: Thu Oct 12 14:00:05 1989 (as ange-ftp) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The following restrictions apply to all of the files in the efs +;;; distribution. +;;; +;;; Copyright (C) 1993 Andy Norman / Sandy Rutherford +;;; +;;; Authors: +;;; Andy Norman (ange@hplb.hpl.hp.com) +;;; Sandy Rutherford (sandy@ibm550.sissa.it) +;;; +;;; The authors of some of the sub-files of efs are different +;;; from the above. We are very grateful to people who have +;;; contributed code to efs. +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's authors (send electronic mail to ange@hplb.hpl.hp.com) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +;;; Description: +;;; +;;; This package attempts to make accessing files and directories on +;;; remote computers from within GNU Emacs as simple and transparent +;;; as possible. Currently all remote files are accessed using FTP. +;;; The goal is to make the entire internet accessible as a virtual +;;; file system. + +;;; Acknowledgements: << please add to this list >> +;;; +;;; Corny de Souza for writing efs-mpe.el. +;;; Jamie Zawinski for writing efs-ti-twenex.el and efs-ti-explorer.el +;;; Joe Wells for writing the first pass at vms support for ange-ftp.el. +;;; Sebastian Kremer for helping with dired support. +;;; Ishikawa Ichiro for MULE support. +;;; +;;; Many other people have contributed code, advice, and beta testing +;;; (sometimes without even realizing it) to both ange-ftp and efs: +;;; +;;; Rob Austein, Doug Bagley, Andy Caiger, Jim Franklin, Noah +;;; Friedman, Aksnes Knut-Havard, Elmar Heeb, John Interrante, Roland +;;; McGrath, Jeff Morgenthaler, Mike Northam, Jens Petersen, Jack +;;; Repenning, Joerg-Martin Schwarz, Michael Sperber, Svein Tjemsland, +;;; Andy Whitcroft, Raymond A. Wiker +;;; +;;; Also, thank you to all the people on the efs-testers mailing list. +;;; + +;;; -------------------------------------------------------------- +;;; Documentation: +;;; -------------------------------------------------------------- +;;; +;;; Currently efs does not have a tex info file, and what you are +;;; reading represents the only efs documentation. Please report any +;;; errors or omissions in this documentation to the "bugs" address +;;; below. Eventually, a tex info file should be written. If you have +;;; any problems with efs, please read this section *before* +;;; submitting a bug report. + +;;; Installation: +;;; +;;; For byte compiling the efs package, a Makefile is provided. +;;; You should follow the instructions at the top of the Makefile. +;;; If you have any problems, please let us know so that we can fix +;;; them for other users. Don't even consider using efs without +;;; byte compiling it. It will be far too slow. +;;; +;;; If you decide to byte compile efs by hand, it is important that +;;; the file efs-defun.el be byte compiled first, followed by efs.el. +;;; The other files may be byte compiled in any order. +;;; +;;; To use efs, simply put the byte compiled files in your load path +;;; and add +;;; +;;; (require 'efs) +;;; +;;; in your .emacs file. +;;; +;;; If you would like efs to be autoloaded when you attempt to access +;;; a remote file, put +;;; +;;; (require 'efs-auto) +;;; +;;; in your .emacs file. Note that there are some limitations associated +;;; with autoloading efs. A discussion of them is given at the top of +;;; efs-auto.el. + +;;; Configuration variables: +;;; +;;; It is important that you read through the section on user customization +;;; variables (search forward for the string ">>>"). If your local network +;;; is not fully connected to the internet, but accesses the internet only +;;; via a gateway, then it is vital to set the appropriate variables to +;;; inform efs about the geometry of your local network. Also, see the +;;; paragraph on gateways below. + +;;; Usage: +;;; +;;; Once installed, efs operates largely transparently. All files +;;; normally accessible to you on the internet, become part of a large +;;; virtual file system. These files are accessed using an extended +;;; file name syntax. To access file on remote host by +;;; logging in as user , you simply specify the full path of the +;;; file as /@:. Nearly all GNU Emacs file handling +;;; functions work for remote files. It is not possible to access +;;; remote files using shell commands in an emacs *shell* buffer, as such +;;; commands are passed directly to the shell, and not handled by emacs. +;;; FTP is the underlying utility that efs uses to operate on remote files. +;;; +;;; For example, if find-file is given a filename of: +;;; +;;; /ange@anorman:/tmp/notes +;;; +;;; then efs will spawn an FTP process, connect to the host 'anorman' as +;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the +;;; contents of that file as if it were on the local file system. If efs +;;; needed a password to connect then it would prompt the user in the +;;; minibuffer. For further discussion of the efs path syntax, see the +;;; paragraph on extended file name syntax below. + +;;; Ports: +;;; +;;; efs supports the use of nonstandard ports on remote hosts. +;;; To specify that port should be used, give the host name as +;;; host#. Host names may be given in this form anywhere that efs +;;; normally expects a host name. This includes in the .netrc file. +;;; Logically, efs treats different ports to correspond to different +;;; remote hosts. + +;;; Extended filename syntax: +;;; +;;; The default full efs path syntax is +;;; +;;; /@#: +;;; +;;; Both the `#' and `@' may be omitted. +;;; +;;; If the `#' is omitted, then the default port is taken to be 21, +;;; the usual FTP port. For most users, the port syntax will only +;;; very rarely be necessary. +;;; +;;; If the `@' is omitted, then efs will use a default user. If a +;;; login token is specified in your .netrc file, then this will be used as +;;; the default user for . Otherwise, it is determined based on the +;;; value of the variable efs-default-user. +;;; +;;; This efs path syntax can be customised to a certain extent by +;;; changing a number of variables in the subsection Internal Variables. +;;; To undertake such a customization requires some knowledge about the +;;; internal workings of efs. + +;;; Passwords: +;;; +;;; A password is required for each host / user pair. This will be +;;; prompted for when needed, unless already set by calling +;;; efs-set-passwd, or specified in a *valid* ~/.netrc file. +;;; +;;; When efs prompts for a password, it provides defaults from its +;;; cache of currently known passwords. The defaults are ordered such +;;; that passwords for accounts which have the same user name as the +;;; login which is currently underway have priority. You can cycle +;;; through your list of defaults with C-n to cycle forwards and C-p +;;; to cycle backwards. The list is circular. + +;;; Passwords for user "anonymous": +;;; +;;; Passwords for the user "anonymous" (or "ftp") are handled +;;; specially. The variable efs-generate-anonymous-password controls +;;; what happens. If the value of this variable is a string, then this +;;; is used as the password; if non-nil, then a password is created +;;; from the name of the user and the hostname of the machine on which +;;; GNU Emacs is running; if nil (the default) then the user is +;;; prompted for a password as normal. + +;;; "Dumb" UNIX hosts: +;;; +;;; The FTP servers on some UNIX machines have problems if the "ls" +;;; command is used. efs will try to correct for this automatically, +;;; and send the "dir" command instead. If it fails, you can call the +;;; function efs-add-host, and give the host type as dumb-unix. Note +;;; that this change will take effect for the current GNU Emacs +;;; session only. To make this specification for future emacs +;;; sessions, put +;;; +;;; (efs-add-host 'dumb-unix "hostname") +;;; +;;; in your .emacs file. Also, please report any failure to automatically +;;; recognize dumb unix to the "bugs" address given below, so that we can +;;; fix the auto recognition code. + +;;; File name completion: +;;; +;;; Full file-name completion is supported on every type of remote +;;; host. To do filename completion, efs needs a listing from the +;;; remote host. Therefore, for very slow connections, it might not +;;; save any time. However, the listing is cached, so subsequent uses +;;; of file-name completion will be just as fast as for local file +;;; names. + +;;; FTP processes: +;;; +;;; When efs starts up an FTP process, it leaves it running for speed +;;; purposes. Some FTP servers will close the connection after a period of +;;; time, but efs should be able to quietly reconnect the next time that +;;; the process is needed. +;;; +;;; The FTP process will be killed should the associated "*ftp user@host*" +;;; buffer be deleted. This should not cause efs any grief. + +;;; Showing background FTP activity on the mode-line: +;;; +;;; After efs is loaded, the command efs-display-ftp-activity will cause +;;; background FTP activity to be displayed on the mode line. The variable +;;; efs-mode-line-format is used to determine how this data is displayed. +;;; efs does not continuously track the number of active sessions, as this +;;; would cause the display to change too rapidly. Rather, it uses a heuristic +;;; algorithm to determine when there is a significant change in FTP activity. + +;;; File types: +;;; +;;; By default efs will assume that all files are ASCII. If a file +;;; being transferred matches the value of efs-binary-file-name-regexp +;;; then the file will be assumed to be a binary file, and efs will +;;; transfer it using "type image". ASCII files will be transferred +;;; using a transfer type which efs computes to be correct according +;;; to its knowledge of the file system of the remote host. The +;;; command `efs-prompt-for-transfer-type' toggles the variable +;;; `efs-prompt-for-transfer-type'. When this variable is non-nil, efs +;;; will prompt the user for the transfer type to use for every FTP +;;; transfer. Having this set all the time is annoying, but it is +;;; useful to give special treatment to a small set of files. +;;; There is also variable efs-text-file-name-regexp. This is tested before +;;; efs-binary-file-name-regexp, so if you set efs-text-file-name-regexp +;;; to a non-trivial regular expression, and efs-binary-file-name-regexp +;;; to ".*", the result will to make image the default tranfer type. +;;; +;;; Also, if you set efs-treat-crlf-as-nl, then efs will use type image +;;; to transfer files between hosts whose file system differ only in that +;;; one specifies end of line as CR-LF, and the other as NL. This is useful +;;; if you are transferring files between UNIX and DOS machines, and have a +;;; package such as dos-mode.el, that handles the extra ^M's. + +;;; Account passwords: +;;; +;;; Some FTP servers require an additional password which is sent by +;;; the ACCOUNT command. efs will detect this and prompt the user for +;;; an account password if the server expects one. Also, an account +;;; password can be set by calling efs-set-account, or by specifying +;;; an account token in the .netrc file. +;;; +;;; Some operating systems, such as CMS, require that ACCOUNT be used to +;;; give a write access password for minidisks. efs-set-account can be used +;;; to set a write password for a specific minidisk. Also, tokens of the form +;;; minidisk +;;; may be added to host lines in your .netrc file. Minidisk tokens must be +;;; at the end of the host line, however there may be an arbitrary number of +;;; them for any given host. + +;;; Preloading: +;;; +;;; efs can be preloaded, but must be put in the site-init.el file and +;;; not the site-load.el file in order for the documentation strings for the +;;; functions being overloaded to be available. + +;;; Status reports: +;;; +;;; Most efs commands that talk to the FTP process output a status +;;; message on what they are doing. In addition, efs can take advantage +;;; of the FTP client's HASH command to display the status of transferring +;;; files and listing directories. See the documentation for the variables +;;; efs-hash-mark-size, efs-send-hash and efs-verbose for more details. + +;;; Caching of directory information: +;;; +;;; efs keeps an internal cache of file listings from remote hosts. +;;; If this cache gets out of synch, it can be renewed by reverting a +;;; dired buffer for the appropriate directory (dired-revert is usually +;;; bound to "g"). +;;; +;;; Alternatively, you can add the following two lines to your .emacs file +;;; if you want C-r to refresh efs's cache whilst doing filename +;;; completion. +;;; (define-key minibuffer-local-completion-map "\C-r" 'efs-re-read-dir) +;;; (define-key minibuffer-local-must-match-map "\C-r" 'efs-re-read-dir) + +;;; Gateways: +;;; +;;; Sometimes it is neccessary for the FTP process to be run on a different +;;; machine than the machine running GNU Emacs. This can happen when the +;;; local machine has restrictions on what hosts it can access. +;;; +;;; efs has support for running the ftp process on a different (gateway) +;;; machine. The way it works is as follows: +;;; +;;; 1) Set the variable 'efs-gateway-host' to the name of a machine +;;; that doesn't have the access restrictions. If you need to use +;;; a nonstandard port to access this host for gateway use, then +;;; specify efs-gateway-host as "#". +;;; +;;; 2) Set the variable 'efs-ftp-local-host-regexp' to a regular expression +;;; that matches hosts that can be contacted from running a local ftp +;;; process, but fails to match hosts that can't be accessed locally. For +;;; example: +;;; +;;; "\\.hp\\.com$\\|^[^.]*$" +;;; +;;; will match all hosts that are in the .hp.com domain, or don't have an +;;; explicit domain in their name, but will fail to match hosts with +;;; explicit domains or that are specified by their ip address. +;;; +;;; 3) Set the variable `efs-local-host-regexp' to machines that you have +;;; direct TCP/IP access. In other words, you must be able to ping these +;;; hosts. Usually, efs-ftp-local-host-regexp and efs-local-host-regexp +;;; will be the same. However, they will differ for so-called transparent +;;; gateways. See #7 below for more details. +;;; +;;; 4) Set the variable 'efs-gateway-tmp-name-template' to the name of +;;; a directory plus an identifying filename prefix for making temporary +;;; files on the gateway. For example: "/tmp/hplose/ange/efs" +;;; +;;; 5) If the gateway and the local host share cross-mounted directories, +;;; set the value of `efs-gateway-mounted-dirs-alist' accordingly. It +;;; is particularly useful, but not mandatory, that the directory +;;; of `efs-gateway-tmp-name-template' be cross-mounted. +;;; +;;; 6) Set the variable `efs-gateway-type' to the type gateway that you have. +;;; This variable is a list, the first element of which is a symbol +;;; denoting the type of gateway. Following elements give further +;;; data on the gateway. +;;; +;;; Supported gateway types: +;;; +;;; a) local: +;;; This means that your local host is itself the gateway. However, +;;; it is necessary to use a different FTP client to gain access to +;;; the outside world. If the name of the FTP client were xftp, you might +;;; set efs-gateway-type to +;;; +;;; (list 'local "xftp" efs-ftp-program-args) +;;; +;;; If xftp required special arguments, then give them in place of +;;; efs-ftp-program-args. See the documentation for efs-ftp-program-args +;;; for the syntax. +;;; +;;; b) proxy: +;;; This indicates that your gateway works by first FTP'ing to it, and +;;; then issuing a USER command of the form +;;; +;;; USER @ +;;; +;;; In this case, you might set efs-gateway-type to +;;; +;;; (list 'proxy "ftp" efs-ftp-program-args) +;;; +;;; If you need to use a nonstandard client, such as iftp, give this +;;; instead of "ftp". If this client needs to take special arguments, +;;; give them instead of efs-ftp-program-args. +;;; +;;; c) remsh: +;;; For this type of gateway, you need to start a remote shell on +;;; your gateway, using either remsh or rsh. You should set +;;; efs-gateway-type to something like +;;; +;;; (list 'remsh "remsh" nil "ftp" efs-ftp-program-args) +;;; +;;; If you use rsh instead of remsh, change the second element from +;;; "remsh" to "rsh". Note that the symbol indicating the gateway +;;; type should still be 'remsh. If you want to pass arguments +;;; to the remsh program, give them as the third element. For example, +;;; if you need to specify a user, make this (list "-l" "sandy"). +;;; If you need to use a nonstandard FTP client, specify that as the fourth +;;; element. If your FTP client needs to be given special arguments, +;;; give them instead of efs-ftp-program-args. +;;; +;;; d) interactive: +;;; This indicates that you need to establish a login on the gateway, +;;; using either telnet or rlogin. +;;; You should set efs-gateway-type to something like +;;; +;;; (list 'interactive "rlogin" nil "exec ftp" efs-ftp-program-args) +;;; +;;; If you need to use telnet, then give "telnet" in place of the second +;;; element "rlogin". If your login program needs to be given arguments, +;;; then they should be given in the third slot. The fourth element +;;; is for the name of the FTP client program. Giving this as "exec ftp", +;;; instead of "ftp", ensures that you are logged out if the FTP client +;;; dies. If the FTP client takes special arguments, give these instead +;;; of efs-ftp-program-args. Furthermore, you should see the documentation +;;; at the top of efs-gwp.el. You may need to set the variables +;;; efs-gwp-setup-term-command, and efs-gwp-prompt-pattern. +;;; +;;; e) raptor: +;;; This is a type of gateway where efs is expected to specify a gateway +;;; user, and send a password for this user using the ACCOUNT command. +;;; For example, to log in to foobar.edu as sandy, while using the account +;;; ange on the gateway, the following commands would be sent: +;;; +;;; open raptorgate.com +;;; quote USER sandy@foobar.edu ange +;;; quote pass +;;; quote account +;;; +;;; For such a gateway, you would set efs-gateway-type to +;;; +;;; (list 'raptor efs-ftp-program efs-ftp-program-args ) +;;; +;;; where is the name of your account on the gateway. In +;;; the above example, this would be "ange". You can set your gateway +;;; password by simply setting an account password for the gateway host. +;;; This can be done with either efs-set-account, or within your .netrc +;;; file. If no password is set, you will be prompted for one. +;;; +;;; f) interlock: +;;; This is a type of gateway where you are expected to send a PASS +;;; command after opening the connection to the gateway. +;;; The precise login sequence is +;;; +;;; open interlockgate +;;; quote PASS +;;; quote USER sandy@foobar.edu +;;; quote PASS +;;; +;;; For such a gateway, you should set efs-gateway-type to +;;; +;;; (list 'interlock efs-ftp-program efs-ftp-program-args) +;;; +;;; If you need to use a nonstandard name for your FTP client, +;;; then replace efs-ftp-program with this name. If your FTP client +;;; needs to take nonstandard arguments, then replace efs-ftp-program-args +;;; with these arguments. See efs-ftp-program-args for the required +;;; syntax. +;;; +;;; If your gateway returns both a 220 code and a 331 code to the +;;; "open interlockgate" command, then you should add a regular +;;; expression to efs-skip-msgs that matches the 220 response. +;;; Returning two response codes to a single FTP command is not permitted +;;; in RFC 959. It is not possible for efs to ignore the 220 by default, +;;; because than it would hang for interlock installations which do not +;;; require a password. +;;; +;;; g) kerberos: +;;; With this gateway, you need to authenticate yourself by getting a +;;; kerberos "ticket" first. Usually, this is done with the kinit program. +;;; Once authenticated, you connect to foobar.com as user sandy with the +;;; sequence: (Note that the "-n" argument inhibits automatic login. +;;; Although, in manual use you probably don't use it, efs always uses it.) +;;; +;;; iftp -n +;;; open foobar.com +;;; user sandy@foobar.com +;;; +;;; You should set efs-gateway-type to something like +;;; +;;; (list 'kerberos "iftp" efs-ftp-program-args "kinit" ) +;;; +;;; If you use an FTP client other than iftp, insert its name instead +;;; of "iftp" above. If your FTP client needs special arguments, give +;;; them as a list of strings in place of efs-ftp-program-args. If +;;; the program that you use to collect a ticket in not called "kinit", +;;; then give its name in place of "kinit" above. should be +;;; any arguments that you need to pass to your kinit program, given as a +;;; list of strings. Most likely, you will give this as nil. +;;; +;;; See the file efs-kerberos.el for more configuration variables. If you +;;; need to adjust any of these variables, please report this to us so that +;;; we can fix them for other users. +;;; +;;; If efs detects that you are not authenticated to use the gateway, it +;;; will run the kinit program automatically, prompting you for a password. +;;; If you give a password in your .netrc file for login the value of +;;; efs-gateway-host and user kerberos, then efs will use this to +;;; obtain gateway authentication. +;;; +;;; 7) Transparent gateways: +;;; +;;; If your gateway is completely transparent (for example it uses +;;; socks), then you should set efs-gateway-type to nil. Also, +;;; set efs-ftp-local-host-regexp to ".*". However, efs-local-host-regexp, +;;; must still be set to a regular expression matching hosts in your local +;;; domain. efs uses this to determine which machines that it can +;;; open-network-stream to. Furthermore, you should still set +;;; efs-gateway-host to the name of your gateway machine. That way efs +;;; will know that this is a special machine having direct TCP/IP access +;;; to both hosts in the outside world, and hosts in your local domain. +;;; +;;; 8) Common Problems with Gateways: +;;; +;;; a) Spurious 220 responses: +;;; Some proxy-style gateways (eg gateway type 'proxy or 'raptor), +;;; return two 3-digit FTP reply codes to the USER command. +;;; For example: +;;; +;;; open gateway.weird +;;; 220 Connected to gateway.weird +;;; quote USER sandy@foobar +;;; 220 Connected to foobar +;;; 331 Password required for sandy +;;; +;;; This is wrong, according to the FT Protocol. Each command must return +;;; exactly one 3-digit reply code. It may be preceded by continuation +;;; lines. What should really be returned is: +;;; +;;; quote USER sandy@foobar +;;; 331-Connected to foobar. +;;; 331 Password required for sandy. +;;; +;;; or even +;;; +;;; quote USER sandy@foobar +;;; 331-220 Connected to foobar. +;;; 331 Password required for sandy. +;;; +;;; Even though the "331-220" looks strange, it is correct protocol, and +;;; efs will parse it properly. +;;; +;;; If your gateway is returning a spurious 220 to USER, a work-around +;;; is to add a regular expression to `efs-skip-msgs' that matches +;;; this line. It must not match the 220 line returned to the open +;;; command. This work-around may not work, as some system FTP clients +;;; also get confused by the spurious 220. In this case, the only +;;; solution is to patch the gateway server. In either case, please +;;; send a bug report to the author of your gateway software. +;;; +;;; b) Case-sensitive parsing of FTP commands: +;;; Some gateway servers seem to treat FTP commands case-sensitively. +;;; This is incorrect, as RFC 959 clearly states that FTP commands +;;; are always to be case-insensitive. If this is a problem with your +;;; gateway server, you should send a bug report to its author. +;;; If efs is using a case for FTP commands that does not suit your server, +;;; a possible work-around is to edit the efs source so that the required +;;; case is used. However, we will not be making any changes to the +;;; standard efs distribution to support this type of server behaviour. +;;; If you need help changing the efs source, you should enquire with the +;;; efs-help mailing list. +;;; + +;;; --------------------------------------------------------------- +;;; Tips for using efs: +;;; --------------------------------------------------------------- + +;;; 1) Beware of compressing files on non-UNIX hosts. efs will do it by +;;; copying the file to the local machine, compressing it there, and then +;;; sending it back. Binary file transfers between machines of different +;;; architectures can be a risky business. Test things out first on some +;;; test files. See "Bugs" below. Also, note that efs sometimes +;;; copies files by moving them through the local machine. Again, +;;; be careful when doing this with binary files on non-Unix +;;; machines. +;;; +;;; 2) Beware that dired over ftp will use your setting of dired-no-confirm +;;; (list of dired commands for which confirmation is not asked). +;;; You might want to reconsider your setting of this variable, +;;; because you might want confirmation for more commands on remote +;;; direds than on local direds. For example, I strongly recommend +;;; that you not include compress in this list. If there is enough +;;; demand it might be a good idea to have an alist +;;; efs-dired-no-confirm of pairs ( TYPE . LIST ), where TYPE is an +;;; operating system type and LIST is a list of commands for which +;;; confirmation would be suppressed. Then remote dired listings +;;; would take their (buffer-local) value of dired-no-confirm from +;;; this alist. Who votes for this? +;;; +;;; 3) Some combinations of FTP clients and servers break and get out of sync +;;; when asked to list a non-existent directory. Some of the ai.mit.edu +;;; machines cause this problem for some FTP clients. Using +;;; efs-kill-ftp-process can be used to restart the ftp process, which +;;; should get things back in synch. +;;; +;;; 4) Some ftp servers impose a length limit on the password that can +;;; be sent. If this limit is exceeded they may bomb in an +;;; incomprehensible way. This sort of behaviour is common with +;;; MVS servers. Therefore, you should beware of this possibility +;;; if you are generating a long password (like an email address) +;;; with efs-generate-anonymous-password. +;;; +;;; 5) Some antiquated FTP servers hang when asked for an RNFR command. +;;; efs sometimes uses this to test whether its local cache is stale. +;;; If your server for HOST hangs when asked for this command, put +;;; (efs-set-host-property HOST 'rnfr-failed t) +;;; in your efs-ftp-startup-function-alist entry for HOST. +;;; + +;;; ----------------------------------------------------------------------- +;;; Where to get the latest version of efs: +;;; ----------------------------------------------------------------------- +;;; +;;; The authors are grateful to anyone or any organization which +;;; provides anonymous FTP distribution for efs. +;;; +;;; +;;; Europe: +;;; +;;; Switzerland +;;; /anonymous@itp.ethz.ch:/sandy/efs/ +;;; +;;; North America: +;;; +;;; Massachusetts, USA +;;; /anonymous@alpha.gnu.ai.mit.edu:/efs/ +;;; +;;; California, USA +;;; /anonymous@ftp.hmc.edu:/pub/emacs/packages/efs/ +;;; +;;; Australia and New Zealand: +;;; +;;; ???????????? +;;; +;;; Japan: +;;; +;;; ???????????? + +;;; --------------------------------------------------------------------- +;;; Non-UNIX support: +;;; --------------------------------------------------------------------- + +;;; efs has full support, incuding file name completion and tree dired +;;; for: +;;; +;;; VMS, CMS, MTS, MVS, ti-twenex, ti-explorer (the last two are lisp +;;; machines), TOPS-20, DOS (running the Distinct, Novell, FTP +;;; software, NCSA, Microsoft in both unix and DOS mode, Super TCP, and +;;; Hellsoft FTP servers), unix descriptive listings (dl), KA9Q, OS/2, +;;; VOS, NOS/VE, CMS running the KNET server, Tandem's Guardian OS, COKE +;;; +;;; efs should be able to automatically recognize any of the operating +;;; systems and FTP servers that it supports. Please report any +;;; failure to do so to the "bugs" address below. You can specify a +;;; certain host as being of a given host type with the command +;;; +;;; (efs-add-host ) +;;; +;;; is a symbol, is a string. If this command is +;;; used interactively, then is prompted for with +;;; completion. Some host types have regexps that can be used to +;;; specify a class of host names as being of a certain type. Note +;;; that if you specify a host as being of a certain type, efs does +;;; not verify that that is really the type of the host. This calls +;;; for caution when using regexps to specify host types, as an +;;; inadvertent match to a regexp might have unpleasant consequences. +;;; +;;; See the respective efs-TYPE.el files for more information. +;;; When or if we get a tex info file, it should contain some more +;;; details on the non-unix support. + +;;; ------------------------------------------------------------------ +;;; Bugs and other things that go clunk in the night: +;;; ------------------------------------------------------------------ + +;;; How to report a bug: +;;; -------------------- +;;; +;;; Type M-x efs-report-bug +;;; or +;;; send mail to efs-bugs@cuckoo.hpl.hp.com. +;;; +;;; efs is a "free" program. This means that you didn't (or shouldn't +;;; have) paid anything for it. It also means that nobody is paid to +;;; maintain it, and the authors weren't paid for writing it. +;;; Therefore, please try to write your bug report in a clear and +;;; complete fashion. It will greatly enhance the probability that +;;; something will be done about your problem. +;;; +;;; Note that efs relies heavily in cached information, so the bug may +;;; depend in a complicated fashion on commands that were performed on +;;; remote files from the beginning of your emacs session. Trying to +;;; reproduce your bug starting from a fresh emacs session is usually +;;; a good idea. +;;; + +;;; Fan/hate mail: +;;; -------------- +;;; +;;; efs has its own mailing list called efs-help. All users of efs +;;; are welcome to subscribe (see below) and to discuss aspects of +;;; efs. New versions of efs are posted periodically to the mailing +;;; list. +;;; +;;; To [un]subscribe to efs-help, or to report mailer problems with the +;;; list, please mail one of the following addresses: +;;; +;;; efs-help-request@cuckoo.hpl.hp.com +;;; or +;;; efs-help-request%cuckoo.hpl.hp.com@hplb.hpl.hp.com +;;; +;;; Please don't forget the -request part. +;;; +;;; For mail to be posted directly to efs-help, send to one of the +;;; following addresses: +;;; +;;; efs-help@cuckoo.hpl.hp.com +;;; or +;;; efs-help%cuckoo.hpl.hp.com@hplb.hpl.hp.com +;;; +;;; Alternatively, there is a mailing list that only gets +;;; announcements of new efs releases. This is called efs-announce, +;;; and can be subscribed to by e-mailing to the -request address as +;;; above. Please make it clear in the request which mailing list you +;;; wish to join. +;;; + +;;; Known bugs: +;;; ----------- +;;; +;;; If you hit a bug in this list, please report it anyway. Most of +;;; the bugs here remain unfixed because they are considered too +;;; esoteric to be a high priority. If one of them gets reported +;;; enough, we will likely change our view on that. +;;; +;;; 1) efs does not check to make sure that when creating a new file, +;;; you provide a valid filename for the remote operating system. +;;; If you do not, then the remote FTP server will most likely +;;; translate your filename in some way. This may cause efs to +;;; get confused about what exactly is the name of the file. +;;; +;;; 2) For CMS support, we send too many cd's. Since cd's are cheap, I haven't +;;; worried about this too much. Eventually, we should have some caching +;;; of the current minidisk. This is complicated by the fact that some +;;; CMS servers lie about the current minidisk, so sending redundant +;;; cd's helps us recover in this case. +;;; +;;; 3) The code to do compression of files over ftp is not as careful as it +;;; should be. It deletes the old remote version of the file, before +;;; actually checking if the local to remote transfer of the compressed +;;; file succeeds. Of course to delete the original version of the file +;;; after transferring the compressed version back is also dangerous, +;;; because some OS's have severe restrictions on the length of filenames, +;;; and when the compressed version is copied back the "-Z" or ".Z" may be +;;; truncated. Then, efs would delete the only remaining version of +;;; the file. Maybe efs should make backups when it compresses files +;;; (of course, the backup "~" could also be truncated off, sigh...). +;;; Suggestions? +;;; +;;; 4) If a dir listing is attempted for an empty directory on (at least +;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and +;;; I don't know how to get efs work to around it. +;;; +;;; 5) efs gets confused by directories containing file names with +;;; embedded newlines. A temporary solution is to add "q" to your +;;; dired listing switches. As long as your dired listing switches +;;; also contain "l" and either "a" or "A", efs will use these +;;; switches to get listings for its internal cache. The "q" switch +;;; should force listings to be exactly one file per line. You +;;; still will not be able to access a file with embedded newlines, +;;; but at least it won't mess up the parsing of the rest of the files. +;;; +;;; 6) efs cannot parse symlinks which have an embedded " -> " +;;; in their name. It's alright to have an embedded " -> " in the name +;;; of any other type of file. A fix is possible, but probably not worth +;;; the trouble. If you disagree, send us a bug report. +;;; +;;; 7) efs doesn't handle context-dep. files in H-switch listings on +;;; HP's. It wouldn't be such a big roaring deal to fix this. I'm +;;; waiting until I get an actual bug report though. +;;; +;;; 8) If a hard link is added or deleted, efs will not update its +;;; internal cache of the link count for other names of the file. +;;; This may cause file-nlinks to return incorrectly. Reverting +;;; any dired buffer containing other names for the file will +;;; cause the file data to be updated, including the link counts. +;;; A fix for this problem is known and will be eventually +;;; implemented. How it is implemented will depend on how we decide +;;; to handle inodes. See below. +;;; +;;; 9) efs is unable to parse R-switch listings from remote unix hosts. +;;; This is inefficient, because efs will insist on doing individual +;;; listings of the subdirectories to get its file information. +;;; This may be fixed if there is enough demand. +;;; +;;; 10) In file-attributes, efs returns a fake inode number. Of course +;;; this is necessary, but this inode number is not even necessarily +;;; unique. It is simply the sum of the characters (treated as +;;; integers) in the host name, user name, and file name. Possible +;;; ways to get a unique inode number are: +;;; a) Simply keep a count of all remote file in the cache, and +;;; return the file's position in this count as a negative number. +;;; b) For unix systems, we could actually get at the real inode +;;; number on the remote host, by adding an "i" to the ls switches. +;;; The inode numbers would then be removed from the listing +;;; returned by efs-ls, if the caller hadn't requested the "i" +;;; switch. We could then make a unique number out of the host name +;;; and the real inode number. +;;; +;;; 11) efs tries to determine if a file is readable or writable by comparing +;;; the file modes, file owner, and user name under which it is logged +;;; into the remote host. This does not take into account groups. +;;; We simply assume that the user belongs to all groups. As a result +;;; we may assume that a file is writable, when in fact it is not. +;;; Groups are tough to handle correctly over FTP. Suggestions? +;;; (For new FTP servers, can do a "QUOTE SITE EXEC groups" to +;;; handle this.) + +;;; ----------------------------------------------------------- +;;; Technical information on this package: +;;; ----------------------------------------------------------- + +;;; efs hooks onto the following functions using the +;;; file-name-handler-alist. Depending on which version of emacs you +;;; are using, not all of these functions may access this alist. In +;;; this case, efs overloads the definitions of these functions with +;;; versions that do access the file-name-handler-alist. These +;;; overloads are done in efs's version-specific files. +;;; +;;; abbreviate-file-name +;;; backup-buffer +;;; copy-file +;;; create-file-buffer +;;; delete-directory +;;; delete-file +;;; directory-file-name +;;; directory-files +;;; file-attributes +;;; file-directory-p +;;; file-exists-p +;;; file-local-copy +;;; file-modes +;;; file-name-all-completions +;;; file-name-as-directory +;;; file-name-completion +;;; file-name-directory +;;; file-name-nondirectory +;;; file-name-sans-versions +;;; file-newer-than-file-p +;;; file-readable-p +;;; file-executable-p +;;; file-accessible-directory-p +;;; file-symlink-p +;;; file-writable-p +;;; get-file-buffer +;;; insert-directory +;;; insert-file-contents +;;; list-directory +;;; make-directory-internal +;;; rename-file +;;; set-file-modes +;;; set-visited-file-modtime +;;; substitute-in-file-name +;;; verify-visited-file-modtime +;;; write-region +;;; +;;; The following functions are overloaded in efs.el, because they cannot +;;; be handled via the file-name-handler-alist. +;;; +;;; expand-file-name +;;; load +;;; read-file-name-internal (Emacs 18, only) +;;; require +;;; +;;; The following dired functions are handled by hooking them into the +;;; the file-name-handler-alist. This is done in efs-dired.el. +;;; +;;; efs-dired-compress-file +;;; eds-dired-print-file +;;; efs-dired-make-compressed-filename +;;; efs-compress-file +;;; efs-dired-print-file +;;; efs-dired-create-directory +;;; efs-dired-recursive-delete-directory +;;; efs-dired-uncache +;;; efs-dired-call-process +;;; +;;; In efs-dired.el, the following dired finctions are overloaded. +;;; +;;; dired-collect-file-versions +;;; dired-find-file +;;; dired-flag-backup-files +;;; dired-get-filename +;;; dired-insert-headerline +;;; dired-move-to-end-of-filename +;;; dired-move-to-filename +;;; dired-run-shell-command +;;; +;;; efs makes use of the following hooks +;;; +;;; diff-load-hook +;;; dired-before-readin-hook +;;; find-file-hooks +;;; dired-grep-load-hook + +;;; LISPDIR ENTRY for the Elisp Archive: +;;; +;;; LCD Archive Entry: +;;; efs|Andy Norman and Sandy Rutherford +;;; |ange@hplb.hpl.hp.com and sandy@ibm550.sissa.it +;;; |transparent FTP Support for GNU Emacs +;;; |$Date: 1997/02/15 22:20:36 $|$efs release: 1.15 beta $| + +;;; Host and listing type notation: +;;; +;;; The functions efs-host-type and efs-listing-type, and the +;;; variable efs-dired-host-type follow the following conventions +;;; for remote host types. +;;; +;;; nil = local host type, whatever that is (probably unix). +;;; Think nil as in "not a remote host". This value is used by +;;; efs-dired-host-type for local buffers. +;;; (efs-host-type nil) => nil +;;; +;;; 'type = a remote host of TYPE type. +;;; +;;; 'type:list = a remote host using listing type 'type:list. +;;; This is currently used for Unix dl (descriptive +;;; listings), when efs-dired-host-type is set to +;;; 'unix:dl, and to support the myriad of DOS FTP +;;; servers. + +;;; Supported host and listing types: +;;; +;;; unknown, unix, dumb-unix, bsd-unix, sysV-unix, next-unix, +;;; super-dumb-unix, dumb-apollo-unix, +;;; apollo-unix, unix:dl, dos-distinct, ka9q, dos, dos:ftp, dos:novell, +;;; dos:ncsa, dos:winsock, vos, hell, dos:microsoft, super-dumb-unix +;;; vms, cms, mts, mvs, mvs:tcp mvs:nih tops-20, mpe, ti-twenex, +;;; ti-explorer, os2, vos, +;;; vms:full, guardian, ms-unix (This is the Microsoft NT Windows server +;;; in unix mode.), plan9, unix:unknown, nos-ve (actually NOS/VE). + +;;; Host and listing type hierarchy: +;;; +;;; unknown: unix, dumb-unix, sysV-unix, bsd-unix, next-unix, apollo-unix, +;;; ka9q, dos-distinct, unix:dl, hell, +;;; super-dumb-unix, dumb-apollo-unix +;;; unix: sysV-unix, bsd-unix, next-unix, apollo-unix, unix:dl +;;; dos: dos:ftp, dos:novell, dos:ncsa, dos:microsoft, dos:winsock +;;; dumb-unix: +;;; bsd-unix: +;;; sysV-unix: +;;; next-unix: +;;; apollo-unix: +;;; dumb-apollo-unix: +;;; unix:dl: +;;; unix:unknown: unix:dl, unix +;;; super-dumb-unix: +;;; dos-distinct: +;;; dos:ftp: +;;; dos:novell: +;;; dos:microsoft +;;; ka9q: +;;; vms: vms:full +;;; cms: +;;; mts: +;;; mvs: mvs:tcp, mvs:nih +;;; mvs:tcp: +;;; mvs:nih: +;;; tops-20: +;;; ti-twenex: +;;; ti-explorer: +;;; os2: +;;; vos: +;;; vms:full: +;;; dos:ncsa: +;;; dos:winsock: +;;; vos: +;;; hell: +;;; guardian: +;;; ms-unix: +;;; plan9: +;;; nos-ve: +;;; coke: +;;; + + +;;;; ================================================================ +;;;; >0 +;;;; Table of Contents for efs.el +;;;; ================================================================ +;; +;; Each section of efs.el is labelled by >#, where # is the number of +;; the section. +;; +;; 1. Provisions, requirements, and autoloads. +;; 2. Variable definitions. +;; 3. Utilities. +;; 4. Hosts, users, accounts, and passwords. +;; 5. FTP client process and server responses. +;; 6. Sending commands to the FTP server. +;; 7. Parsing and storing remote file system data. +;; 8. Redefinitions of standard GNU Emacs functions. +;; 9. Multiple host type support. +;; 10. Attaching onto the appropriate emacs version. + + +;;;; ================================================================ +;;;; >1 +;;;; General provisions, requirements, and autoloads. +;;;; Host type, and local emacs type dependent loads, and autoloads +;;;; are in the last two sections of this file. +;;;; ================================================================ + +;;;; ---------------------------------------------------------------- +;;;; Provide the package (Do this now to avoid an infinite loop) +;;;; ---------------------------------------------------------------- + +(provide 'efs) + +;;;; ---------------------------------------------------------------- +;;;; Our requirements. +;;;; ---------------------------------------------------------------- + +(require 'backquote) +(require 'comint) +(require 'efs-defun) +(require 'efs-netrc) +(require 'efs-cu) +(require 'efs-ovwrt) +;; Do this last, as it installs efs into the file-name-handler-alist. +(require 'efs-fnh) + +(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) +(autoload 'efs-gwp-start "efs-gwp" ; For interactive gateways. + "Login to the gateway machine and fire up an FTP client.") +(autoload 'efs-kerberos-login "efs-kerberos") +(autoload 'efs-insert-directory "efs-dired" "Insert a directory listing.") +(autoload 'efs-set-mdtm-of "efs-cp-p") +(autoload 'diff-latest-backup-file "diff") +(autoload 'read-passwd "passwd" "Read a password from the minibuffer." t) + + +;;;; ============================================================ +;;;; >2 +;;;; Variable Definitions +;;;; **** The user configuration variables are in **** +;;;; **** the second subsection of this section. **** +;;;; ============================================================ + +;;;; ------------------------------------------------------------ +;;;; Constant Definitions +;;;; ------------------------------------------------------------ + +(defconst efs-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.2 $" 11 -2))) + +(defconst efs-time-zero 1970) ; we count time from midnight, Jan 1, 1970 GMT. + +(defconst efs-dumb-host-types + '(dumb-unix super-dumb-unix vms cms mts ti-twenex ti-explorer dos mvs + tops-20 mpe ka9q dos-distinct os2 vos hell guardian + netware cms-knet nos-ve coke dumb-apollo-unix) + "List of host types that can't take UNIX ls-style listing options.") +;; dos-distinct only ignores ls switches; it doesn't barf. +;; Still treat it as dumb. + +(defconst efs-unix-host-types + '(unix sysV-unix bsd-unix next-unix apollo-unix dumb-unix + dumb-apollo-unix super-dumb-unix) + "List of unix host types.") + +(defconst efs-version-host-types '(vms tops-20 ti-twenex ti-explorer) + "List of host-types which associated a version number to all files. +This is not the same as associating version numbers to only backup files.") +;; Note that on these systems, +;; (file-name-sans-versions EXISTING-FILE) does not exist as a file. + +(defconst efs-single-extension-host-types + '(vms tops-20 ti-twenex ti-explorer cms mvs dos ka9q dos-distinct hell + netware ms-unix plan9 cms-knet nos-ve) + "List of host types which allow at most one extension on a file name. +Extensions are deliminated by \".\". In addition, these host-types must +allow \"-\" in file names, because it will be used to add additional extensions +to indicate compressed files.") + +(defconst efs-idle-host-types + (append '(coke unknown) efs-unix-host-types)) +;; List of host types for which it is possible that the SITE IDLE command +;; is supported. + +(defconst efs-listing-types + '(unix:dl unix:unknown + dos:novell dos:ftp dos:ncsa dos:microsoft dos:stcp dos:winsock + mvs:nih mvs:tcp mvs:tcp + vms:full) + "List of supported listing types") + +(defconst efs-nlist-listing-types + '(vms:full)) +;; Listing types which give a long useless listing when asked for a +;; LIST. For these, use an NLST instead. This can only be done +;; when there is some way to distinguish directories from +;; plain files in an NLST. + +(defconst efs-opaque-gateways '(remsh interactive)) +;; List of gateway types for which we need to do explicit file handling on +;; the gateway machine. + +;;;; ------------------------------------------------------------------ +;;;; User customization variables. Please read through these carefully. +;;;; ------------------------------------------------------------------ + +;;;>>>> If you are not fully connected to the internet, <<<< +;;;>>>> and need to use a gateway (no matter how transparent) <<<< +;;;>>>> you will need to set some of the following variables. <<<< +;;;>>>> Read the documentation carefully. <<<< + +(defvar efs-local-host-regexp ".*" + "Regexp to match names of local hosts. +These are hosts to which it is possible to obtain a direct internet +connection. Even if the host is accessible by a very transparent FTP gateway, +it does not qualify as a local host. The test to determine if machine A is +local to your machine is if it is possible to ftp from A _back_ to your +local machine. Also, open-network-stream must be able to reach the host +in question.") + +(defvar efs-ftp-local-host-regexp ".*" + "Regexp to match the names of hosts reachable by a direct ftp connection. +This regexp should match the names of hosts which can be reached using ftp, +without requiring any explicit connection to a gateway. If you have a smart +ftp client which is able to transparently go through a gateway, this will +differ from `efs-local-host-regexp'.") + +(defvar efs-gateway-host nil + "If non-nil, this must be the name of your ftp gateway machine. +If your net world is divided into two domains according to +`efs-local-ftp-host-regexp', set this variable to the name of the +gateway machine.") + +(defvar efs-gateway-type nil + "Specifies which type of gateway you wish efs to use. +This should be a list, the first element of which is a symbol denoting the +gateway type, and following elements give data on how to use the gateway. + +The following possibilities are supported: + + '(local FTP-PROGRAM FTP-PROGRAM-ARGS) + This means that your local host is itself the gateway. However, + you need to run a special FTP client to access outside hosts. + FTP-PROGRAM should be the name of this FTP client, and FTP-PROGRAM-ARGS + is a list of arguments to pass to it \(probably set this to the value of + efs-ftp-program-args \). Note that if your gateway is of this type, + then you would set efs-gateway-host to nil. + + '(proxy FTP-PROGRAM FTP-PROGRAM-ARGS) + This indicates that your gateway works by first FTP'ing to it, and + then giving a USER command of the form \"USER @\". + FTP-PROGRAM is the FTP program to use to connect to the gateway; this + is most likely \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to + pass to it. You likely want this to be set to the value of + efs-ftp-program-args . If the connection to the gateway FTP server + is to be on a port different from 21, set efs-gateway-host to + \"#\". + + '(raptor FTP-PROGRAM FTP-PROGRAM-ARGS USER) + This is for the gateway called raptor by Eagle. After connecting to the + the gateway, the command \"user @host USER\" is issued to login + as on , where USER is an authentication username for the + gateway. After issuing the password for the remote host, efs will + send the password for USER on efs-gateway-host as an account command. + + '(interlock FTP-PROGRAM FTP-PROGRAM-ARGS) + This is for the interlock gateway. The exact login sequence is to + connect to the gateway specified by efs-gateway-host , send the + gateway password with a PASS command, send the command + \"user @\" to connect to remote host as user , + and finally to send the password for on with a second + PASS command. + + '(kerberos FTP-PROGRAM FTP-PROGRAM-ARGS KINIT-PROGRAM KINIT-PROGRAM-ARGS) + This is for the kerberos gateway where you need to run a program (kinit) to + obtain a ticket for gateway authroization first. FTP-PROGRAM should be + the name of the FTP client that you use to connect to the gateway. This + may likely be \"iftp\". FTP-PROGRAM-ARGS are the arguments that you need + to pass to FTP-PROGRAM. This is probably the value of + efs-ftp-program-args . KINIT-PROGRAM is the name of the program to + run in order to obtain a ticket. This is probably \"kinit\". + KINIT-PROGRAM-ARGS is a list og strings indicating any arguments that you + need to pass to KINIT-PROGRAM. Most likely this is nil. + + '(remsh GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM FTP-PROGRAM-ARGS) + This indicates that you wish to run FTP on your gateway using a remote shell. + GATEWAY-PROGRAM is the name of the program to use to start a remote shell. + It is assumed that it is not necessary to provide a password to start + this remote shell. Likely values are \"remsh\" or \"rsh\". + GATEWAY-PROGRAM-ARGS is a list of arguments to pass to GATEWAY-PROGRAM. + FTP-PROGRAM is the name of the FTP program on the gateway. A likely setting + of this is \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass to + FTP-PROGRAM. Most likely these should be set to the value of + efs-ftp-program-args . + + '(interactive GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM + FTP-PROGRAM-ARGS) + This indicates that you need to start an interactive login on your gatway, + using rlogin, telnet, or something similar. GATEWAY-PROGRAM is the name + of the program to use to log in to the gateway, and GATEWAY-PROGRAM-ARGS + is a list of arguments to pass to it. FTP-PROGRAM is the name of the FTP + program on the gateway. A likely setting for this variable would be + \"exec ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass + to FTP-PROGRAM. You probably want to set these to the same value as + efs-ftp-program-args . If you are using this option, read the + documentation at the top of efs-gwp.el, and see + efs-gwp-setup-term-command .") + +(defvar efs-gateway-hash-mark-size nil + "*Value of `efs-hash-mark-size' for FTP clients on `efs-gateway-host'. +See the documentation of these variables for more information.") + +(defvar efs-gateway-incoming-binary-hm-size nil + "*Value of `efs-incoming-binary-hm-size' for `efs-gateway-host'. +See documentation of these variables for more information.") + +(defvar efs-gateway-tmp-name-template "/tmp/efs" + "Template used to create temporary files when ftp-ing through a gateway. +This should be the name of the file on the gateway, and not necessarily +the name on the local host.") + +(defvar efs-gateway-mounted-dirs-alist nil + "An alist of directories cross-mounted between the gateway and local host. +Each entry is of the form \( DIR1 . DIR2 \), where DIR1 is the name of the +directory on the local host, and DIR2 is its name on the remote host. Both +DIR1 and DIR2 must be specified in directory syntax, i.e. end in a slash. +Note that we will assume that subdirs of DIR1 and DIR2 are also accessible +on both machines.") + +(defvar efs-gateway-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" + "*Regular expression to match the prompt of the gateway FTP client.") + +;;; End of gateway config variables. + +(defvar efs-tmp-name-template "/tmp/efs" + "Template used to create temporary files. +If you are worried about security, make this a directory in some +bomb-proof cave somewhere. efs does clean up its temp files, but +they do live for short periods of time.") + +(defvar efs-generate-anonymous-password t + "*If t, use a password of `user@host' when logging in as the anonymous user. +`host' is generated by the function `efs-system-fqdn'. If `system name' returns +a fully qualified domain name, `efs-system-fqdn' will return this. Otherwise, +it will attempt to use nslookup to obtain a fully qualified domain name. If +this is unsuccessful, the returned value will be the same as `system-name', +whether this is a fully qualified domain name or not. + +If a string then use that as the password. + +If nil then prompt the user for a password. + +Beware that some operating systems, such as MVS, restrict substantially +the password length. The login will fail with a weird error message +if you exceed it.") + +(defvar efs-high-security-hosts nil + "*Indicates host user pairs for which passwords should not be cached. +If non-nil, should be a regexp matching user@host constructions for which +efs should not store passwords in its internal cache.") + +;; The following regexps are tested in the following order: +;; efs-binary-file-host-regexp, efs-36-bit-binary-file-name-regexp, +;; efs-binary-file-name-regexp, efs-text-file-name-regexp. +;; File names which match nothing are transferred in 'image mode. + +;; If we're not careful, we're going to blow the regexp stack here. +;; Probably should move to a list of regexps. Slower, but safer. +;; This is not a problem in Emacs 19. +(defvar efs-binary-file-name-regexp + (concat "\\." ; the dot + ;; extensions + "\\([zZ]\\|t?gz\\|lzh\\|arc\\|zip\\|zoo\\|ta[rz]\\|dvi\\|sit\\|" + "ps\\|elc\\|gif\\|Z-part-..\\|tpz\\|exe\\|[jm]pg\\|TZ[a-z]?\\|lib\\)" + "\\(~\\|~[0-9]+~\\)?$" ; backups + "\\|" + ;; UPPER CASE LAND + "\\." + "\\(ARC\\|ELC\\|TAGS\\|EXE\\|ZIP\\|DVI\|ZOO\\|GIF\\|T?GZ\\|" + "[JM]PG\\)" + "\\([.#;][0-9]+\\)?$" ; versions + ) + "*Files whose names match this regexp will be considered to be binary. +By binary here, we mean 8-bit binary files (the usual unix binary files). +If nil, no files will be considered to be binary.") + +(defvar efs-binary-file-host-regexp nil + "*All files on hosts matching this regexp are treated as 8-bit binary. +Setting this to nil, inhibits this feature.") + +(defvar efs-36-bit-binary-file-name-regexp nil + "*Files whose names match this regexp will be considered to PDP 10 binaries. +These are 36-bit word-aligned binary files. This is really only relevant for +files on PDP 10's, and similar machines. If nil, no files will be considered +to be PDP 10 binaries.") + +(defvar efs-text-file-name-regexp ".*" + "*Files whose names match this regexp will be considered to be text files.") + +(defvar efs-prompt-for-transfer-type nil + "*If non-nil, efs will prompt for the transfer type for each file transfer. +The command efs-prompt-for-transfer-type can be used to toggle its value.") + +(defvar efs-treat-crlf-as-nl nil + "*Controls how file systems using CRLF as end of line are treated. +If non-nil, such file systems will be considered equivalent to those which use +LF as end of line. This is particularly relevant to transfers between DOS +systems and UNIX. Setting this to be non-nil will cause all file transfers +between DOS and UNIX systems to use be image or binary transfers.") + +(defvar efs-send-hash t + "*If non-nil, send the HASH command to the FTP client.") + +(defvar efs-hash-mark-size nil + "*Default size, in bytes, between hash-marks when transferring a file. +If this is nil then efs will attempt to assign a value based on the +output of the HASH command. Also, if this variable is incorrectly set, +then efs will try to correct it based on the size of the last file +transferred, and the number hashes outputed by the client during the +transfer. + +The variable `efs-gateway-hash-mark-size' defines the corresponding value +for the FTP client on the gateway, if you are using a gateway. + +Some client-server combinations do not correctly compute the number of hash +marks for incoming binary transfers. In this case, a separate variable +`efs-incoming-binary-hm-size' can be used to set a default value of the +hash mark size for incoming binary transfers.") + +(defvar efs-incoming-binary-hm-size nil + "*Default hash mark size for incoming binary transfers. +If this is nil, incoming binary transfers will use `efs-hash-mark-size' as +the default. See the documentation of this variable for more details.") + +(defvar efs-verbose t + "*If non-NIL then be chatty about interaction with the FTP process. +If 0 do not give % transferred reports for asynchronous commands and status +reports for commands verifying file modtimes, but report on everything else.") + +(defvar efs-message-interval 0 + "*Defines the minimum time in seconds between status messages. +A new status message is not displayed, if one has already been given +within this period of time.") + +(defvar efs-max-ftp-buffer-size 3000 + "*Maximum size in characters of FTP process buffer, before it is trimmed. +The buffer is trimmed to approximately half this size. Setting this to nil +inhibits trimming of FTP process buffers.") + +(defvar efs-ls-cache-max 5 + "*Maximum number of directory listings to be cached in efs-ls-cache.") + +(defvar efs-mode-line-format " ftp(%d)" + "Format string used to determine how FTP activity is shown on the mode line. +It is passed to format, with second argument the number of active FTP +sessions as an integer.") + +(defvar efs-show-host-type-in-dired t + "If non-nil, show the system type on the mode line of remote dired buffers.") + +(defvar efs-ftp-activity-function nil + "Function called to indicate FTP activity. +It must have exactly one argument, the number of active FTP sessions as an +integer.") + +(defvar efs-ftp-program-name "ftp" + "Name of FTP program to run.") + +(defvar efs-ftp-program-args '("-i" "-n" "-g" "-v") + "*A list of arguments passed to the FTP program when started.") + +(defvar efs-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" + "*Regular expression to match the prompt of your FTP client.") + +(defvar efs-nslookup-program "nslookup" + "*If non-NIL then a string naming nslookup program." ) + +(defvar efs-nslookup-on-connect nil + "*If non-NIL then use nslookup to resolve the host name before connecting.") + +(defvar efs-nslookup-threshold 1000 + "How many iterations efs waits on the nslookup program. +Applies when nslookup is used to compute a fully qualified domain name +for the local host, in the case when `system-name' does not return one. +If you set this to nil, efs will wait an arbitrary amount of time to get +output.") + +(defvar efs-make-backup-files efs-unix-host-types + "*A list of operating systems for which efs will make Emacs backup files. +The backup files are made on the remote host. + +For example: +'\(unix sysV-unix bsd-unix apollo-unix dumb-unix\) makes sense, but +'\(unix vms\) would be silly, since vms makes its own backups.") + +;; Is this variable really useful? We should try to figure a way to +;; do local copies on a remote machine that doesn't take forever. +(defvar efs-backup-by-copying nil + "*Version of `backup by copying' for remote files. +If non-nil, remote files will be backed up by copying, instead of by renaming. +Note the copying will be done by moving the file through the local host -- a +very time consuming operation.") + +;;; Auto-save variables. Relevant for auto-save.el + +(defvar efs-auto-save 0 + "*If 1, allows efs files to be auto-saved. +If 0, suppresses auto-saving of efs files. +Don't use any other value.") + +(defvar efs-auto-save-remotely nil + "*Determines where remote files are auto-saved. + +If nil, auto-saves for remote files will be written in `auto-save-directory' +or `auto-save-directory-fallback' if this isn't defined. + +If non-nil, causes the auto-save file for an efs file to be written in +the remote directory containing the file, rather than in a local directory. +For remote files, this overrides a non-nil `auto-save-directory'. Local files +are unaffected. If you want to use this feature, you probably only want to +set this true in a few buffers, rather than globally. You might want to give +each buffer its own value using `make-variable-buffer-local'. It is usually +a good idea to auto-save remote files locally, because it is not only faster, +but provides protection against a connection going down. + +See also variable `efs-auto-save'.") + +(defvar efs-short-circuit-to-remote-root nil + "*Defines whether \"//\" short-circuits to the remote or local root.") + +;; Can we somehow grok this from system type? No. +(defvar efs-local-apollo-unix + (eq 0 (string-match "//" (or (getenv "HOME") (getenv "SHELL") ""))) + "*Defines whether the local machine is an apollo running Domain. +This variable has nothing to do with efs, and should be basic to all +of emacs.") + +(defvar efs-root-umask nil + "*umask to use for root logins.") + +(defvar efs-anonymous-umask nil + "*umask to use for anonymous logins.") + +(defvar efs-umask nil + "*umask to use for efs sessions. +If this is nil, then the setting of umask on the local host is used.") + +;; Eliminate these variables when Sun gets around to getting its FTP server +;; out of the stone age. +(defvar efs-ding-on-umask-failure t + "*Ring the bell if the umask command fails on a unix host. Many servers don't +support this command, so if you get a lot of annoying failures, set this +to nil.") + +(defvar efs-ding-on-chmod-failure t + "*Ring the bell if the chmod command fails on a unix host. Some servers don't +support this command, so if you get a lot of annoying failures, set this +to nil.") + +;; Please let us know if you can contribute more entries to this guessing game. +(defvar efs-nlist-cmd + (cond + ;; Covers Ultrix, SunOS, and NeXT. + ((eq system-type 'berkeley-unix) + "ls") + ((memq system-type '(hpux aix-v3 silicon-graphics-unix)) + "nlist") + ;; Blind guess + ("ls")) + "*FTP client command for getting a brief listing (NLST) from the FTP server. +We try to guess this based on the local system-type, but obviously if you +are using a gateway, you'll have to set it yourself.") + +(defvar efs-compute-remote-buffer-file-truename nil + "*If non-nil, `buffer-file-truename' will be computed for remote buffers. +In emacs 19, each buffer has a local variable, `buffer-file-truename', +which is used to ensure that symbolic links will not confuse emacs into +visiting the same file with two buffers. This variable is computed by +chasing all symbolic links in `buffer-file-name', both at the level of the +file and at the level of all parent directories. Since this operation can be +very time-consuming over FTP, this variable can be used to inhibit it.") + +(defvar efs-buffer-name-case nil + "*Selects the case used for buffer names of case-insensitive file names. +Case-insensitive file names are files on hosts whose host type is in +`efs-case-insensitive-host-types'. + +If this is 'up upper case is used, if it is 'down lower case is used. +If this has any other value, the case is inherited from the name used +to access the file.") + +(defvar efs-fancy-buffer-names "%s@%s" + "Format used to compute names of buffers attached to remote files. + +If this is nil, buffer names are computed in the usual way. + +If it is a string, then the it is passed to format with second and third +arguments the host name and file name. + +Otherwise, it is assumed to be function taking three arguments, the host name, +the user name, and the truncated file name. It should returns the name to +be used for the buffer.") + +(defvar efs-verify-anonymous-modtime nil + "*Determines if efs checks modtimes for remote files on anonymous logins. +If non-nil, efs runs `verify-visited-file-modtime' for remote files on +anonymous ftp logins. Since verify-visited-file-modtime slows things down, +and most people aren't editing files on anonymous ftp logins, this is nil +by default.") + +(defvar efs-verify-modtime-host-regexp ".*" + "*Regexp to match host names for which efs checks file modtimes. +If non-nil, efs will run `verify-visited-file-modtime' for remote +files on hosts matching this regexp. If nil, verify-visited-file-modtime +is supressed for all remote hosts. This is tested before +`efs-verify-anonymous-modtime'.") + +(defvar efs-maximize-idle nil + "*If non-nil, efs will attempt to maximize the idle time out period. +At some idle moment in the connection after login, efs will attempt to +set the idle time out period to the maximum amount allowed by the server. +It applies only to non-anonymous logins on unix hosts.") + +(defvar efs-expire-ftp-buffers t + "*If non-nil ftp buffers will be expired. +The buffers will be killed either after `efs-ftp-buffer-expire-time' has +elapsed with no activity, or the remote FTP server has timed out.") + +(defvar efs-ftp-buffer-expire-time nil + "*If non-nil, the time after which ftp buffers will be expired. +If nil, ftp buffers will be expired only when the remote server has timed out. +If an integer, ftp buffers will be expired either when the remote server +has timed out, or when this many seconds on inactivity has elapsed.") + +;; If you need to increase this variable much, it is likely that +;; the true problem is timing errors between the efs process filter +;; and the FTP server. This could either be caused by the server +;; not following RFC959 response codes, or a bug in efs. In either +;; case please report the problem to us. If it's a bug, we'll fix it. +;; If the server is at fault we may try to do something. Our rule +;; of thumb is that we will support non-RFC959 behaviour, as long as +;; it doesn't risk breaking efs for servers which behave properly. + +(defvar efs-retry-time 5 + "*Number of seconds to wait before retrying if data doesn't arrive. +The FTP command isn't retried, rather efs just takes a second look +for the data file. This might need to be increased for very slow FTP +clients.") + +(defvar efs-pty-check-threshold 1000 + "*How long efs waits before deciding that it doesn't have a pty. +Specifically it is the number of iterations through `accept-process-output' +that `efs-pty-p' waits before deciding that the pty is really a pipe. +Set this to nil to inhibit checking for pty's. If efs seems to be +mistaking some pty's for pipes, try increasing this number.") + +(defvar efs-pty-check-retry-time 5 + "*Number of seconds that efs waits before retrying a pty check. +This can be lengthened, if your FTP client is slow to start.") + +(defvar efs-suppress-abort-recursive-edit-and-then nil + "*If non-nil, `efs-abort-recursive-edit-and-then' will not run its function. +This means that when a recursive edit is in progress, automatic popping of the +FTP process buffer, and automatic popping of the bug report buffer will not +work. `efs-abort-recursive-edit-and-then' works by forking a \"sleep 0\" +process. On some unix implementations the forked process might be of the same +size as the original GNU Emacs process. Forking such a large process just to +do a \"sleep 0\" is probably not good.") + +(defvar efs-ftp-buffer-format "*ftp %s@%s*" + "Format to construct the name of FTP process buffers. +This string is fed to `format' with second and third arguments the user +name and host name.") +;; This does not affect the process name of the FTP client process. +;; That is always *ftp USER@HOST* + +(defvar efs-debug-ftp-connection nil + "*If non-nil, the user will be permitted to debug the FTP connection. +This means that typing a C-g to the FTP process filter will give the user +the option to type commands at the FTP connection. Normally, the connection +is killed first. Note that doing this may result in the FTP process filter +getting out of synch with the FTP client, so using this feature routinely +isn't recommended.") + +;;; Hooks and crooks. + +(defvar efs-ftp-startup-hook nil + "Hook to run immediately after starting the FTP client. +This hook is run before the FTP OPEN command is sent.") + +(defvar efs-ftp-startup-function-alist nil + "Association list of functions to running after FTP login. +This should be an alist of the form '\(\(REGEXP . FUNCTION\) ...\), where +REGEXP is a regular expression matched against the name of the remote host, +and FUNCTION is a function of two arguments, HOST and USER. REGEXP is +compared to the host name with `case-fold-search' bound to t. Only the first +match in the alist is run.") + +(defvar efs-load-hook nil + "Hook to run immediately after loading efs.el. +You can use it to alter definitions in efs.el, but why would you want +to do such a thing?") + +;;;; ----------------------------------------------------------- +;;;; Regexps for parsing FTP server responses. +;;;; ----------------------------------------------------------- +;;; +;;; If you have to tune these variables, please let us know, so that +;;; we can get them right in the next release. + +(defvar efs-multi-msgs + ;; RFC959 compliant codes + "^[1-5][0-5][0-7]-") +;; Regexp to match the start of an FTP server multiline reply. + +(defvar efs-skip-msgs + ;; RFC959 compliant codes + (concat + "^110 \\|" ; Restart marker reply. + "^125 \\|" ; Data connection already open; transfer starting. + "^150 ")) ; File status OK; about to open connection. +;; Regexp to match an FTP server response which we wish to ignore. + +(defvar efs-cmd-ok-msgs + ;; RFC959 compliant + "^200 \\|^227 ") +;; Regexp to match the server command OK response. +;; Because PORT commands return this we usually ignore it. However, it is +;; a valid response for TYPE, SITE, and a few other commands (cf. RFC 959). +;; If we are explicitly sending a PORT, or one of these other commands, +;; then we don't want to ignore this response code. Also use this to match +;; the return code for PASV, as some clients burp these things out at odd +;; times. + +(defvar efs-pending-msgs + ;; RFC959 compliant + "^350 ") ; Requested file action, pending further information. +;; Regexp to match the \"requested file action, pending further information\" +;; message. These are usually ignored, except if we are using RNFR to test for +;; file existence. + +(defvar efs-cmd-ok-cmds + (concat + "^quote port \\|^type \\|^quote site \\|^chmod \\|^quote noop\\|" + "^quote pasv")) +;; Regexp to match commands for which efs-cmd-ok-msgs is a valid server +;; response for success. + +(defvar efs-passwd-cmds + "^quote pass \\|^quote acct \\|^quote site gpass ") +;; Regexp to match commands for sending passwords. +;; All text following (match-end 0) will be replaced by "Turtle Power!" + +(defvar efs-bytes-received-msgs + ;; Strictly a client response + "^[0-9]+ bytes ") +;; Regexp to match the reply from the FTP client that it has finished +;; receiving data. + +(defvar efs-server-confused-msgs + ;; ka9q uses this to indicate an incorrectly set transfer mode, and + ;; then does send a second completion code for the command. This does + ;; *not* conform to RFC959. + "^100 Warning: type is ") +;; Regexp to match non-standard response from the FTP server. This can +;; sometimes be the result of an incorrectly set transfer mode. In this case +;; we do not rely on the server to tell us when the data transfer is complete, +;; but check with the client. + +(defvar efs-good-msgs + (concat + ;; RFC959 compliant codes + "^2[01345][0-7] \\|" ; 2yz = positive completion reply + "^22[02-7] \\|" ; 221 = successful logout + ; (Sometimes get this with a timeout, + ; so treat as fatal.) + "^3[0-5][0-7] \\|" ; 3yz = positive intermediate reply + ;; client codes + "^[Hh]ash mark ")) +;; Response to indicate that the requested action was successfully completed. + +(defvar efs-failed-msgs + (concat + ;; RFC959 compliant codes + "^120 \\|" ; Service ready in nnn minutes. + "^450 \\|" ; File action not taken; file is unavailable, or busy. + "^452 \\|" ; Insufficient storage space on system. + "^5[0-5][0-7] \\|" ; Permanent negative reply codes. + ;; When clients tell us that a file doesn't exist, or can't access. + "^\\(local: +\\)?/[^ ]* +" + "\\([Nn]o such file or directory\\|[Nn]ot a plain file\\|" + "The file access permissions do not allow \\|Is a directory\\b\\)")) +;; Regexp to match responses for failed commands. However, the ftp connection +;; is assumed to be good. + +(defvar efs-fatal-msgs + (concat + ;; RFC959 codes + "^221 \\|" ; Service closing control connection. + "^421 \\|" ; Service not available. + "^425 \\|" ; Can't open data connection. + "^426 \\|" ; Connection closed, transfer aborted. + "^451 \\|" ; Requested action aborted, local error in processing. + ;; RFC959 non-compliant codes + "^552 Maximum Idle Time Exceded\\.$\\|" ; Hellsoft server uses this to + ; indicate a timeout. 552 is + ; supposed to be used for exceeded + ; storage allocation. Note that + ; they also misspelled the error + ; message. + ;; client problems + "^ftp: \\|^Not connected\\|^rcmd: \\|^No control connection\\|" + "^unknown host\\|: unknown host$\\|^lost connection\\|" + "^[Ss]egmentation fault\\|" + ;; Make sure that the "local: " isn't just a message about a file. + "^local: [^/]\\|" + ;; Gateways + "^iftp: cannot authenticate to server\\b" + )) +;; Regexp to match responses that something has gone drastically wrong with +;; either the client, server, or connection. We kill the ftp process, and start +;; anew. + +(defvar efs-unknown-response-msgs + "^[0-9][0-9][0-9] ") +;; Regexp to match server response codes that we don't understand. This +;; is tested after all the other regexp, so it can match everything. + +(defvar efs-pasv-msgs + ;; According to RFC959. + "^227 .*(\\([0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+\\))$") +;; Matches the output of a PASV. (match-beginning 1) and (match-end 1) +;; must bracket the IP address and port. + +(defvar efs-syst-msgs "^215 \\|^210 ") +;; 215 is RFC959. Plan 9 FTP server returns a 210. 210 is not assigned in +;; RFC 959. +;; The plan 9 people tell me that they fixed this. -- sr 18/4/94 +;; Matches the output of a SYST. + +(defvar efs-mdtm-msgs + (concat + "^213 [0-9][0-9][0-9][0-9][0-9][0-9][0-9]" + "[0-9][0-9][0-9][0-9][0-9][0-9][0-9]$")) +;; Regexp to match the output of a quote mdtm command. + +(defvar efs-idle-msgs + "^200 [^0-9]+ \\([0-9]+\\)[^0-9]* max \\([0-9]+\\)") +;; Regexp to match the output of a SITE IDLE command. +;; Match 1 should refer to the current idle time, and match 2 the maximum +;; idle time. + +(defvar efs-write-protect-msgs "^532 ") ; RFC959 +;; Regexp to match a server ressponse to indicate that a STOR failed +;; because of insufficient write privileges. + +(defvar efs-hash-mark-msgs + "[hH]ash mark [^0-9]*\\([0-9]+\\)") +;; Regexp matching the FTP client's output upon doing a HASH command. + +(defvar efs-xfer-size-msgs + (concat + ;; UN*X + "^150 .* connection for .* (\\([0-9]+\\) bytes)\\|" + ;; Wollongong VMS server. + "^125 .* transfer started for .* (\\([0-9]+\\) bytes)\\|" + ;; TOPS-20 server + "^150 .* retrieve of .* ([0-9]+ pages?, \\([0-9]+\\) 7-bit bytes)")) +;; Regular expression used to determine the number of bytes +;; in a FTP transfer. The first (match-beginning #) which is non-nil is assumed +;; to give the size. + +(defvar efs-expand-dir-msgs "^550 \\([^: ]+\\):") +;; Regexp to match the error response from a "get ~sandy". +;; By parsing the error, we can get a quick expansion of ~sandy +;; According to RFC 959, should be a 550. + +(defvar efs-gateway-fatal-msgs + "No route to host\\|Connection closed\\|No such host\\|Login incorrect") +;; Regular expression matching messages from the rlogin / telnet process that +;; indicates that logging in to the gateway machine has gone wrong. + +(defvar efs-too-many-users-msgs + ;; The test for "two many" is because some people can't spell. + ;; I allow for up to two adjectives before "users". + (concat + "\\b[Tt][wo]o many\\( +[^ \n]+\\)?\\( +[^ \n]+\\)? +users\\b\\|" + "\\btry back later\\b")) +;; Regular expresion to match what servers output when there are too many +;; anonymous logins. It is assumed that this is part of a 530 or 530- response +;; to USER or PASS. + +;;;; ------------------------------------------------------------- +;;;; Buffer local FTP process variables +;;;; ------------------------------------------------------------- + +;;; Variables buffer local to the process buffers are +;;; named with the prefix efs-process- + +(defvar efs-process-q nil) +;; List of functions to be performed asynch. +(make-variable-buffer-local 'efs-process-q) + +(defvar efs-process-cmd-waiting nil) +;; Set to t if a process has a synchronous cmd waiting to execute. +;; In this case, it will allow the synch. cmd to run before returning to +;; the cmd queue. +(make-variable-buffer-local 'efs-process-cmd-waiting) + +(defvar efs-process-server-confused nil) +(make-variable-buffer-local 'efs-process-server-confused) + +(defvar efs-process-cmd nil) +;; The command currently being executed, as a string. +(make-variable-buffer-local 'efs-process-cmd) + +(defvar efs-process-xfer-size 0) +(make-variable-buffer-local 'efs-process-xfer-size) + +(defvar efs-process-umask nil) +;; nil if the umask hash not been set +;; an integer (the umask) if the umask has been set +(make-variable-buffer-local 'efs-process-umask) + +(defvar efs-process-idle-time nil) +;; If non-nil, the idle time of the server in seconds. +(make-variable-buffer-local 'efs-process-idle-time) + +(defvar efs-process-busy nil) +(make-variable-buffer-local 'efs-process-busy) + +(defvar efs-process-result-line "") +(make-variable-buffer-local 'efs-process-result-line) + +(defvar efs-process-result nil) +(make-variable-buffer-local 'efs-process-result) + +(defvar efs-process-result-cont-lines "") +(make-variable-buffer-local 'efs-process-result-cont-lines) + +(defvar efs-process-msg "") +(make-variable-buffer-local 'efs-process-msg) + +(defvar efs-process-nowait nil) +(make-variable-buffer-local 'efs-process-nowait) + +(defvar efs-process-string "") +(make-variable-buffer-local 'efs-process-string) + +(defvar efs-process-continue nil) +(make-variable-buffer-local 'efs-process-continue) + +(defvar efs-process-hash-mark-count 0) +(make-variable-buffer-local 'efs-process-hash-mark-count) + +(defvar efs-process-hash-mark-unit nil) +(make-variable-buffer-local 'efs-process-hash-mark-unit) + +(defvar efs-process-last-percent -1) +(make-variable-buffer-local 'efs-process-last-percent) + +(defvar efs-process-host nil) +(make-variable-buffer-local 'efs-process-host) + +(defvar efs-process-user nil) +(make-variable-buffer-local 'efs-process-user) + +(defvar efs-process-host-type nil) +;; Holds the host-type as a string, for showing it on the mode line. +(make-variable-buffer-local 'efs-process-host-type) + +(defvar efs-process-xfer-type nil) +;; Set to one of 'ascii, 'ebcdic, 'image, 'tenex, or nil to indicate +;; the current setting of the transfer type for the connection. nil means +;; that we don't know. +(make-variable-buffer-local 'efs-process-xfer-type) + +(defvar efs-process-client-altered-xfer-type nil) +;; Sometimes clients alter the xfer type, such as doing +;; an ls it is changed to ascii. If we are using quoted commands +;; to do xfers the client doesn't get a chance to set it back. +(make-variable-buffer-local 'efs-process-client-altered-xfer-type) + +(defvar efs-process-prompt-regexp nil) +;; local value of prompt of FTP client. +(make-variable-buffer-local 'efs-process-prompt-regexp) + +(defvar efs-process-cmd-counter 0) +;; Counts FTP commands, mod 16. +(make-variable-buffer-local 'efs-process-cmd-counter) + +;;;; ------------------------------------------------------------ +;;;; General Internal Variables. +;;;; ------------------------------------------------------------ + +;;; For the byte compiler +;; +;; These variables are usually unbound. We are just notifying the +;; byte compiler that we know what we are doing. + +(defvar bv-length) ; getting file versions. +(defvar default-file-name-handler-alist) ; for file-name-handler-alist +(defvar efs-completion-dir) ; for file name completion predicates +(defvar dired-directory) ; for default actions in interactive specs +(defvar dired-local-variables-file) ; for inhibiting child look ups +(defvar dired-in-query) ; don't clobber dired queries with stat messages +(defvar after-load-alist) ; in case we're in emacs 18. +(defvar comint-last-input-start) +(defvar comint-last-input-end) +(defvar explicit-shell-file-name) + +;;; fluid vars + +(defvar efs-allow-child-lookup t) +;; let-bind to nil, if want to inhibit child lookups. + +(defvar efs-nested-cmd nil) +;; let-bound to t, when a cmd is executed by a cont or pre-cont. +;; Such cmds will never end by looking at the next item in the queue, +;; if they are run synchronously, but rely on their calling function +;; to do this. + +;;; polling ftp buffers + +(defvar efs-ftp-buffer-poll-time 300 + "Period, in seconds, which efs will poll ftp buffers for activity. +Used for expiring \(killing\) inactive ftp buffers.") + +(defconst efs-ftp-buffer-alist nil) +;; alist of ftp buffers, and the total number of seconds that they +;; have been idle. + +;;; load extensions + +(defvar efs-load-lisp-extensions '(".elc" ".el" "") + "List of extensions to try when loading lisp files.") + +;;; mode-line + +(defvar efs-mode-line-string "") +;; Stores the string that efs displays on the mode line. + +;;; data & temporary buffers + +(defvar efs-data-buffer-name " *ftp data*") +;; Buffer name to hold directory listing data received from ftp process. + +(defvar efs-data-buffer-name-2 " *ftp data-2*") +;; A second buffer name in which to hold directory listings. +;; Used for listings which are made during another directory listing. + +;;; process names + +(defvar efs-ctime-process-name-format "*efs ctime %s*") +;; Passed to format with second arg the host name. + +;;; For temporary files. + +;; This is a list of symbols. +(defconst efs-tmp-name-files ()) +;; Here is where these symbols live: +(defconst efs-tmp-name-obarray (make-vector 7 0)) +;; We put our version of the emacs PID here: +(defvar efs-pid nil) + +;;; For abort-recursive-edit + +(defvar efs-abort-recursive-edit-data nil) +(defvar efs-abort-recursive-edit-delay 5) +;; Number of seconds after which efs-abort-recursive-edit-and-then +;; will decide not to runs its sentinel. The assumption is that something +;; went wrong. + +;;; hashtables (Use defconst's to clobber any user silliness.) + +(defconst efs-files-hashtable (efs-make-hashtable 97)) +;; Hash table for storing directories and their respective files. + +(defconst efs-expand-dir-hashtable (efs-make-hashtable)) +;; Hash table of tilde expansions for remote directories. + +(defconst efs-ls-converter-hashtable (efs-make-hashtable 37)) +;; Hashtable for storing functions to convert listings from one +;; format to another. Keys are the required switches, and the values +;; are alist of the form ((SWITCHES . CONVERTER)...) where is SWITCHES +;; are the listing switches for the original listing, and CONVERTER is a +;; function of one-variable, the listing-type, to do the conversion +;; on data in the current buffer. SWITCHES is either a string, or nil. +;; nil means that the listing can be converted from cache in +;; efs-files-hashtable, a string from cache in efs-ls-cache. For the latter, +;; listings with no switches (dumb listings), represent SWITCHES as a string +;; consisting only of the ASCII null character. + +;;; cache variables (Use defconst's to clobber any user sillines.) + +(defconst efs-ls-cache nil + "List of results from efs-ls. +Each entry is a list of four elements, the file listed, the switches used +\(nil if none\), the listing string, and whether this string has already been +parsed.") + +(defvar efs-ls-uncache nil) +;; let-bind this to t, if you want to be sure that efs-ls will replace any +;; cache entries. + +;; This is a cache to see if the user has changed +;; completion-ignored-extensions. +(defconst efs-completion-ignored-extensions completion-ignored-extensions + "This variable is internal to efs. Do not set. +See completion-ignored-extensions, instead.") + +;; We cache the regexp we use for completion-ignored-extensions. This +;; saves building a string every time we do completion. String construction +;; is costly in emacs. +(defconst efs-completion-ignored-pattern + (mapconcat (function + (lambda (s) (if (stringp s) + (concat (regexp-quote s) "$") + "/"))) ; / never in filename + efs-completion-ignored-extensions + "\\|") + "This variable is internal to efs. Do not set. +See completion-ignored-extensions, instead.") + +(defvar efs-system-fqdn nil + "Cached value of the local systems' fully qualified domain name.") + +;;; The file-type-alist + +;; efs-file-type-alist is an alist indexed by host-type +;; which stores data on how files are structured on the given +;; host-type. Each entry is a list of three elements. The first is the +;; definition of a `byte', the second the native character representation, +;; and the third, the file structure. +;; +;; Meanings of the symbols: +;; ------------------------ +;; The byte symbols: +;; 8-bit = bytes of 8-bits +;; 36-bit-wa = 36-bit word aligned. Precisely, the addressing unit is that +;; of a PDP-10 using the "<440700,,0> byte pointer". +;; +;; The native character set symbols: +;; 8-ascii = 8-bit NVT-ASCII +;; 7-ascii = 7-bit ascii as on a PDP-10 +;; ebcdic = EBCDIC as on an IBM mainframe +;; lispm = the native character set on a lispm (Symbolics and LMI) +;; mts = native character representation in the Michigan Terminal System +;; (which runs on IBM and Amdal mainframes), similar to ebcdic +;; +;; The file structure symbols: +;; +;; file-nl = data is stored as a contiguous sequence of data bytes +;; with EOL denoted by . +;; file-crlf = data is stored as a contiguous sequence of data bytes +;; with EOL denoted by +;; record = data is stored as a sequence of records +;; file-lispm = data as stored on a lispm. i.e. a sequence of bits +;; with EOL denoted by character code 138 (?) +;; +;; If we've messed anything up here, please let us know. + +(defvar efs-file-type-alist + '((unix . (8-bit 8-ascii file-nl)) + (sysV-unix . (8-bit 8-ascii file-nl)) + (bsd-unix . (8-bit 8-ascii file-nl)) + (apollo-unix . (8-bit 8-ascii file-nl)) + (dumb-apollo-unix . (8-bit 8-ascii file-nl)) + (dumb-unix . (8-bit 8-ascii file-nl)) + (super-dumb-unix . (8-bit 8-ascii file-nl)) + (guardian . (8-bit ascii file-nl)) + (plan9 . (8-bit 8-ascii file-nl)) + (dos . (8-bit 8-ascii file-crlf)) + (ms-unix . (8-bit 8-ascii file-crlf)) + (netware . (8-bit 8-ascii file-crlf)) + (os2 . (8-bit 8-ascii file-crlf)) + (tops-20 . (36-bit-wa 7-ascii file-crlf)) + (mpe . (8-bit 8-ascii record)) + (mvs . (8-bit ebcdic record)) + (cms . (8-bit ebcdic record)) + (cms-knet . (8-bit ebcdic record)) + (mts . (8-bit mts record)) ; mts seems to have its own char rep. + ; Seems to be close to ebcdic, but not the same. + (dos-distinct . (8-bit 8-ascii file-crlf)) + (ka9q . (8-bit 8-ascii file-crlf)) + (vms . (8-bit 8-ascii record)) ; The mysteries of VMS's RMS. + (hell . (8-bit 8-ascii file-crlf)) + (vos . (8-bit 8-ascii record)) + (ti-explorer . (8-bit lispm file-lispm)) ; lispms use a file structure, but + ; use an out of range char to + ; indicate EOL. + (ti-twenex . (8-bit lispm file-lispm)) + (nos-ve . (8-bit 8-ascii record)) + (coke . (8-bit 8-ascii file-nl)) ; only support 8-bit beverages + (nil . (8-bit 8-ascii file-nl)))) ; the local host + +;;; Status messages + +(defvar efs-last-message-time -86400) ; yesterday +;; The time of the last efs status message. c.f. efs-message-interval + +;;; For handling dir listings + +;; This MUST match all the way to to the start of the filename. +;; This version corresponds to what dired now uses (sandy, 14.1.93) +(defvar efs-month-and-time-regexp + (concat + " \\([0-9]+\\) +" ; file size + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct" + ; June and July are for HP-UX 9.0 + "\\|Nov\\|Dec\\) \\([ 0-3][0-9]\\)\\(" + " [012][0-9]:[0-6][0-9] \\|" ; time + " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo + ; HP-UX, A/UX + " [12][90][0-9][0-9] \\)" ; year on AIX + )) + +(defvar efs-month-alist + '(("Jan" . 1) ("Feb". 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) + ("June" . 6) ("Jul" . 7) ("July" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) + ("Nov" . 11) ("Dec" . 12))) + +;; Matches the file modes, link number, and owner string. +;; The +/- is for extended file access permissions. +(defvar efs-modes-links-owner-regexp + (concat + "\\([^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ]\\)[-+]? *\\([0-9]+\\)" + " +\\([^ ]+\\) ")) + +;;;; --------------------------------------------------------------- +;;;; efs-dired variables +;;;; --------------------------------------------------------------- + +;; These variables must be here, instead of in efs-dired.el, because +;; the efs-HOST-TYPE.el files need to add to it. +(defvar efs-dired-re-exe-alist nil + "Association list of regexps which match file lines of executable files.") + +(defvar efs-dired-re-dir-alist nil + "Association list of regexps which match file lines of subdirectories.") + +(defvar efs-dired-host-type nil + "Host type of a dired buffer. \(buffer local\)") +(make-variable-buffer-local 'efs-dired-host-type) + +(defvar efs-dired-listing-type nil + "Listing type of a dired buffer. \(buffer local\)") +(make-variable-buffer-local 'efs-dired-listing-type) + +(defvar efs-dired-listing-type-string nil) +(make-variable-buffer-local 'efs-dired-listing-type-string) + +;;;; ------------------------------------------------------------- +;;;; New error symbols. +;;;; ------------------------------------------------------------- + +(put 'ftp-error 'error-conditions '(ftp-error file-error error)) +;; (put 'ftp-error 'error-message "FTP error") + + +;;;; ============================================================= +;;;; >3 +;;;; Utilities +;;;; ============================================================= + +;;; ------------------------------------------------------------------- +;;; General Macros (Make sure that macros are defined before they're +;;; used, for the byte compiler. +;;; ------------------------------------------------------------------- + +(defmacro efs-kbd-quit-protect (proc &rest body) + ;; When an efs function controlling an FTP connection gets a kbd-quit + ;; this tries to make sure that everything unwinds consistently. + (let ((temp (make-symbol "continue"))) + (list 'let + (list '(quit-flag nil) + '(inhibit-quit nil) + (list temp t)) + (list + 'while temp + (list 'setq temp nil) + (list + 'condition-case nil + (cons 'progn + body) + (list 'quit + (list 'setq temp + (list 'efs-kbd-quit-protect-cover-quit proc)))))))) + +(defun efs-kbd-quit-protect-cover-quit (proc) + ;; This function exists to keep the macro expansion of the + ;; efs-kbd-quit-protect down to a reasonable size. + (let ((pop-up-windows t) + (buff (get-buffer (process-buffer proc))) + res) + (if (save-window-excursion + (if buff + (progn + (pop-to-buffer buff) + (goto-char (point-max)) + (recenter (- (window-height) + 2)))) + (setq res (efs-kill-ftp-buffer-with-prompt proc buff))) + (progn + (if (eq res 0) + (if (eq (selected-window) + (minibuffer-window)) + (efs-abort-recursive-edit-and-then + (function + (lambda (buff) + (if (get-buffer buff) + (display-buffer buff)))) + buff) + (if (get-buffer buff) + (display-buffer buff)) + (signal 'quit nil)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal (quote quit) nil))) + nil) + (sit-for 0) + (message "Waiting on %s..." (or (car (efs-parse-proc-name proc)) + "a whim")) + t))) + +(put 'efs-kbd-quit-protect 'lisp-indent-hook 1) + +(defmacro efs-save-buffer-excursion (&rest forms) + "Execute FORMS, restoring the current buffer afterwards. +Unlike, save-excursion, this does not restore the point." + (let ((temp (make-symbol "saved-buff"))) + (list 'let + (list (list temp '(current-buffer))) + (list 'unwind-protect + (cons 'progn forms) + (list 'condition-case nil + (list 'set-buffer temp) + '(error nil)))))) + +(put 'efs-save-buffer-excursion 'lisp-indent-hook 0) + +(defmacro efs-unquote-dollars (string) + ;; Unquote $$'s to $'s in STRING. + (` (let ((string (, string)) + (start 0) + new) + (while (string-match "\\$\\$" string start) + (setq new (concat new (substring + string start (1+ (match-beginning 0)))) + start (match-end 0))) + (if new + (concat new (substring string start)) + string)))) + +(defmacro efs-get-file-part (path) + ;; Given PATH, return the file part used for looking up the file's entry + ;; in a hashtable. + ;; This need not be the same thing as file-name-nondirectory. + (` (let ((file (file-name-nondirectory (, path)))) + (if (string-equal file "") + "." + file)))) + +(defmacro efs-ftp-path-macro (path) + ;; Just a macro version of efs-ftp-path, for speed critical + ;; situations. Could use (inline ...) instead, but not everybody + ;; uses the V19 byte-compiler. Also, doesn't call efs-save-match-data, + ;; but assumes that the calling function does it. + (` + (let ((path (, path))) + (or (string-equal path efs-ftp-path-arg) + (setq efs-ftp-path-res + (and (string-match efs-path-regexp path) + (let ((host (substring path (match-beginning 2) + (match-end 2))) + (user (and (match-beginning 1) + (substring path (match-beginning 1) + (1- (match-end 1))))) + (rpath (substring path (1+ (match-end 2))))) + (list (if (string-equal host "") + (setq host (system-name)) + host) + (or user (efs-get-user host)) + rpath))) + ;; Set this last, in case efs-get-user calls this function, + ;; which would modify an earlier setting. + efs-ftp-path-arg path)) + efs-ftp-path-res))) + +(defmacro efs-canonize-switches (switches) + ;; Converts a switches string, into a lexographically ordered string, + ;; omitting - and spaces. Should we remove duplicate characters too? + (` (if (, switches) + (mapconcat + 'char-to-string + (sort (delq ?- (delq ?\ (mapcar 'identity (, switches)))) '<) "") + ;; For the purpose of interning in a hashtable, represent the nil + ;; switches, as a string consisting of the ascii null character. + (char-to-string 0)))) + +(defmacro efs-canonize-file-name (fn) + ;; Canonizes the case of file names. + (` (let ((parsed (efs-ftp-path (, fn)))) + (if parsed + (let ((host (car parsed))) + (if (memq (efs-host-type host) efs-case-insensitive-host-types) + (downcase (, fn)) + (format efs-path-format-string (nth 1 parsed) (downcase host) + (nth 2 parsed)))) + (, fn))))) + +(defmacro efs-get-files-hashtable-entry (fn) + (` (efs-get-hash-entry (efs-canonize-file-name (, fn)) efs-files-hashtable))) + +;;;; ------------------------------------------------------------ +;;;; Utility Functions +;;;; ------------------------------------------------------------ + +(defun efs-kill-ftp-buffer-with-prompt (proc buffer) + ;; Does a 3-way prompt to kill a ftp PROC and BUFFER. + ;; Returns t if buffer was killed, 0 if only process, nil otherwise. + (let ((inhibit-quit t) + (cursor-in-echo-area t) + char) + (message + (if efs-debug-ftp-connection + "Kill ftp process and buffer (y[es], n[o], c[lose], d[ebug] ) " + "Kill ftp process and buffer? (y or n, c to only close process) ")) + (setq char (read-char)) + (prog1 + (cond + ((memq char '(?y ?Y ?\ )) + (set-process-sentinel proc nil) + (condition-case nil + (kill-buffer buffer) + (error nil)) + t) + ((memq char '(?c ?C)) + (set-process-sentinel proc nil) + (condition-case nil + (save-excursion + (set-buffer buffer) + (setq efs-process-busy nil + efs-process-q nil) + (delete-process proc)) + (error nil)) + 0) + ((memq char '(?n ?N)) + (message "") + nil) + ((and efs-debug-ftp-connection + (memq char '(?d ?D))) + (condition-case nil + (save-excursion + (set-buffer buffer) + (setq efs-process-busy nil + efs-process-q nil)) + (error nil)) + 0) + (t + (message + (if efs-debug-ftp-connection + "Type one of y, n, c or d." + "Type one of y, n or c.")) + (ding) + (sit-for 1) + (setq quit-flag nil) + (efs-kill-ftp-buffer-with-prompt proc buffer)))))) + +(defun efs-barf-if-not-directory (directory) + ;; Signal an error if DIRECTORY is not one. + (or (file-directory-p directory) + (signal 'file-error + (list "Opening directory" + (if (file-exists-p directory) + "not a directory" + "no such file or directory") + directory)))) + +(defun efs-call-cont (cont &rest args) + "Call the function specified by CONT. +CONT can be either a function or a list of a function and some args. +The first parameters passed to the function will be ARGS. The remaining +args will be taken from CONT if a list was passed." + (if cont + (let ((efs-nested-cmd t)) ; let-bound so that conts don't pop any queues + (efs-save-buffer-excursion + (if (and (listp cont) + (not (eq (car cont) 'lambda))) + (apply (car cont) (append args (cdr cont))) + (apply cont args)))))) + +(defun efs-replace-path-component (fullpath path) + "For FULLPATH matching efs-path-regexp replace the path component with PATH." + (efs-save-match-data + (if (string-match efs-path-root-regexp fullpath) + (concat (substring fullpath 0 (match-end 0)) path) + path))) + +(defun efs-abort-recursive-edit-and-then (fun &rest args) + ;; Does an abort-recursive-edit, and runs fun _after_ emacs returns to + ;; top level. + (if (get-process "efs-abort-recursive-edit") + ;; Don't queue these things. Clean them out. + (delete-process "efs-abort-recursive-edit")) + (or efs-suppress-abort-recursive-edit-and-then + (progn + (setq efs-abort-recursive-edit-data (cons (nth 1 (current-time)) + (cons fun args))) + (condition-case nil + (set-process-sentinel + (let ((default-directory exec-directory) + (process-connection-type nil)) + (start-process "efs-abort-recursive-edit" nil "sleep" "0")) + (function + (lambda (proc string) + (let ((data efs-abort-recursive-edit-data)) + (setq efs-abort-recursive-edit-data) + (if (and data + (integerp (car data)) + (<= (- (nth 1 (current-time)) (car data)) + efs-abort-recursive-edit-delay)) + (apply (nth 1 data) (nthcdr 2 data))))))) + (error nil)))) + (abort-recursive-edit)) + +(defun efs-occur-in-string (char string) + ;; Return the number of occurrences of CHAR in STRING. + (efs-save-match-data + (let ((regexp (regexp-quote (char-to-string char))) + (count 0) + (start 0)) + (while (string-match regexp string start) + (setq start (match-end 0) + count (1+ count))) + count))) + +(defun efs-parse-proc-name (proc) + ;; Parses the name of process to return a list \(host user\). + (efs-save-match-data + (let ((name (process-name proc))) + (and name + (string-match "^\\*ftp \\([^@]*\\)@\\([^*]+\\)\\*$" name) + (list (substring name (match-beginning 2) (match-end 2)) + (substring name (match-beginning 1) (match-end 1))))))) + +;;;; ------------------------------------------------------------ +;;;; Of Geography, connectivity, and the internet... Gateways. +;;;; ------------------------------------------------------------ + +(defun efs-use-gateway-p (host &optional opaque-p) +;; Returns whether to access this host via a gateway. +;; Returns the gateway type as a symbol. See efs-gateway-type . +;; If optional OPAQUE-P is non-nil, only returns non-nil if the gateway +;; type is in the list efs-opaque-gateways . + (and efs-gateway-type + host ;local host is nil + (efs-save-match-data + (and (not (string-match efs-ftp-local-host-regexp host)) + (let ((type (car efs-gateway-type))) + (if opaque-p + (and (memq type efs-opaque-gateways) type) + type)))))) + +(defun efs-local-to-gateway-filename (filename &optional reverse) + ;; Converts a FILENAME on the local host to its name on the gateway, + ;; using efs-gateway-mounted-dirs-alist. If REVERSE is non-nil, does just + ;; that. If the there is no corresponding name because non of its parent + ;; directories are mounted, returns nil. + (if efs-gateway-mounted-dirs-alist + (let ((len (length filename)) + (alist efs-gateway-mounted-dirs-alist) + result elt elt-len) + (if reverse + (while (setq elt (car alist)) + (if (and (>= len (setq elt-len (length (cdr elt)))) + (string-equal (cdr elt) (substring filename 0 elt-len))) + (setq result (concat (car elt) + (substring filename elt-len)) + alist nil) + (setq alist (cdr alist)))) + (while (setq elt (car alist)) + (if (and (>= len (setq elt-len (length (car elt)))) + (string-equal (car elt) (substring filename 0 elt-len))) + (setq result (concat (cdr elt) + (substring filename elt-len)) + alist nil) + (setq alist (cdr alist))))) + result))) + +;;; ------------------------------------------------------------ +;;; Enhanced message support. +;;; ------------------------------------------------------------ + +(defun efs-message (fmt &rest args) + "Output the given message, truncating to the size of the minibuffer window." + (let ((msg (apply (function format) fmt args)) + (max (window-width (minibuffer-window)))) + (if (>= (length msg) max) + (setq msg (concat "> " (substring msg (- 3 max))))) + (message "%s" msg))) + +(defun efs-message-p () + ;; Returns t, if efs is allowed to display a status message. + (not + (or (and (boundp 'dired-in-query) dired-in-query) + (boundp 'search-message) + cursor-in-echo-area + (and (/= efs-message-interval 0) + (let ((diff (- efs-last-message-time + (setq efs-last-message-time + (nth 1 (current-time)))))) + (and + (> diff (- efs-message-interval)) + (< diff 0))))))) ; in case the clock wraps. + +(efs-define-fun efs-relativize-filename (file &optional dir new) + "Abbreviate the given filename relative to DIR . +If DIR is nil, use the value of `default-directory' for the currently selected +window. If the optional parameter NEW is given and the +non-directory parts match, only return the directory part of the file." + (let* ((dir (or dir (save-excursion + (set-buffer (window-buffer (selected-window))) + default-directory))) + (dlen (length dir)) + (result file)) + (and (> (length file) dlen) + (string-equal (substring file 0 dlen) dir) + (setq result (substring file dlen))) + (and new + (string-equal (file-name-nondirectory result) + (file-name-nondirectory new)) + (or (setq result (file-name-directory result)) + (setq result "./"))) + (abbreviate-file-name result))) + +;;; ------------------------------------------------------------ +;;; Temporary file location and deletion... +;;; ------------------------------------------------------------ + +(defun efs-get-pid () + ;; Half-hearted attempt to get the current process's id. + (setq efs-pid (substring (make-temp-name "") 1))) + +(defun efs-make-tmp-name (host1 host2) + ;; Returns the name of a new temp file, for moving data between HOST1 + ;; and HOST2. This temp file must be directly accessible to the + ;; FTP client connected to HOST1. Using nil for either HOST1 or + ;; HOST2 means the local host. The return value is actually a list + ;; whose car is the name of the temp file wrto to the local host + ;; and whose cdr is the name of the temp file wrto to the host + ;; on which the client connected to HOST1 is running. If the gateway + ;; is only accessible by FTP, then the car of this may be in efs extended + ;; file name syntax. + (let ((pid (or efs-pid (efs-get-pid))) + (start ?a) + file entry template rem-template template-len) + ;; Compute the templates. + (if (null (and host1 (efs-use-gateway-p host1 t))) + ;; file must be local + (if (null (and host2 (efs-use-gateway-p host2 t))) + (setq template efs-tmp-name-template) + (setq template (or (efs-local-to-gateway-filename + efs-gateway-tmp-name-template t) + efs-tmp-name-template))) + ;; file must be on the gateway -- make sure that the gateway + ;; configuration is sensible. + (efs-save-match-data + (or (string-match efs-ftp-local-host-regexp efs-gateway-host) + (error "Gateway %s must be directly ftp accessible." + efs-gateway-host))) + (setq rem-template efs-gateway-tmp-name-template + template (or (efs-local-to-gateway-filename + efs-gateway-tmp-name-template t) + (format efs-path-format-string + (efs-get-user efs-gateway-host) + efs-gateway-host + efs-gateway-tmp-name-template)) + template-len (length template))) + ;; Compute a new file name. + (while (let (efs-verbose) + (setq file (format "%s%c%s" template start pid) + entry (intern file efs-tmp-name-obarray)) + (or (memq entry efs-tmp-name-files) + (file-exists-p file))) + (if (> (setq start (1+ start)) ?z) + (progn + (setq template (concat template "X")) + (setq start ?a)))) + (setq efs-tmp-name-files + (cons entry efs-tmp-name-files)) + (if rem-template + (cons file (concat rem-template (substring file template-len))) + (cons file file)))) + +(defun efs-del-tmp-name (temp) + ;; Deletes file TEMP, a string. + (setq efs-tmp-name-files + (delq (intern temp efs-tmp-name-obarray) + efs-tmp-name-files)) + (condition-case () + (let (efs-verbose) + (delete-file temp)) + (error nil))) + + +;;;; ============================================================== +;;;; >4 +;;;; Hosts, Users, Accounts, and Passwords +;;;; ============================================================== +;;; +;;; A lot of the support for this type of thing is in efs-netrc.el. + +;;;; ------------------------------------------------------------ +;;;; Password support. +;;;; ------------------------------------------------------------ + +(defun efs-lookup-passwd (host user) + ;; Look up the password for HOST and USER. + (let ((ent (efs-get-host-user-property host user 'passwd))) + (and ent (efs-code-string ent)))) + +(defun efs-system-fqdn () + "Returns a fully qualified domain name for the current host, if possible." + (or efs-system-fqdn + (setq efs-system-fqdn + (let ((sys (system-name))) + (if (string-match "\\." sys) + sys + (if efs-nslookup-program + (let ((proc (let ((default-directory exec-directory) + (process-connection-type nil)) + (start-process " *nslookup*" " *nslookup*" + efs-nslookup-program sys))) + (res sys) + (n 0)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (let ((quit-flag nil) + (inhibit-quit nil)) + (if efs-nslookup-threshold + (progn + (while (and (memq (process-status proc) + '(run open)) + (< n efs-nslookup-threshold)) + (accept-process-output) + (setq n (1+ n))) + (if (>= n efs-nslookup-threshold) + (progn + (with-output-to-temp-buffer "*Help*" + (princ (format "\ +efs is unable to determine a fully qualified domain name +for the local host to send as an anonymous ftp password. + +The function `system-name' is not returning a fully qualified +domain name. An attempt to obtain a fully qualified domain name +with `efs-nslookup-program' (currently set to \"%s\") has +elicited no response from that program. Consider setting +`efs-generate-anonymous-password' to an email address for anonymous +ftp passwords. + +For more information see the documentation (use C-h v) for the +variables `efs-nslookup-program' and `efs-nslookup-threshold'." + efs-nslookup-program))) + (error "No response from %s" + efs-nslookup-program)))) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc))) + (goto-char (point-min)) + (if (re-search-forward + (format "^Name: *\\(%s\\.[^ \n\t]+\\)" + sys) nil t) + (setq res (buffer-substring + (match-beginning 1) + (match-end 1))) + (kill-buffer (current-buffer))))) + res) + sys)))))) + +(defun efs-passwd-unique-list (alist) + ;; Preserving the relative order of ALIST, remove all entries with duplicate + ;; cars. + (let (result) + (while alist + (or (assoc (car alist) result) + (setq result (cons (car alist) result))) + (setq alist (cdr alist))) + (nreverse result))) + +(defun efs-get-passwd-list (user host) + ;; Returns an alist of the form '((pass host user) ...). + ;; The order is essentially arbitrary, except that entries with user + ;; equal to USER will appear first. Followed by entries with host equal to + ;; HOST. Also, there will be no entries with duplicate values of pass. + (efs-parse-netrc) + (let* ((user-template (concat "/" user)) + (ulen (length user-template)) + (hlen (length host)) + primaries secondaries tertiaries) + (efs-save-match-data + (efs-map-hashtable + (function + (lambda (key passwd) + (cond ((null passwd) nil) + ((and (> (length key) ulen) + (string-equal user-template + (substring key (- ulen)))) + (setq primaries (cons (list (efs-code-string passwd) + (substring key 0 (- ulen)) + (substring user-template 1)) + primaries))) + ((and (> (length key) hlen) + (string-equal host (substring key 0 hlen)) + (memq (aref key hlen) '(?/ ?.))) + (if (string-match "/" key hlen) + (setq secondaries + (cons (list (efs-code-string passwd) + (substring key 0 (match-beginning 0)) + (substring key (match-end 0))) + secondaries)))) + ((string-match "/" key) + (setq tertiaries + (cons (list (efs-code-string passwd) + (substring key 0 (match-beginning 0)) + (substring key (match-end 0))) + tertiaries)))))) + efs-host-user-hashtable 'passwd)) + (efs-passwd-unique-list (nconc primaries secondaries tertiaries)))) + +(defun efs-get-passwd (host user) + "Given a HOST and USER, return the FTP password, prompting if it was not +previously set." + (efs-parse-netrc) + + ;; look up password in the hash table first; user might have overriden the + ;; defaults. + (cond ((efs-lookup-passwd host user)) + + ;; see if default user and password set from the .netrc file. + ((and (stringp efs-default-user) + efs-default-password + (string-equal user efs-default-user)) + (copy-sequence efs-default-password)) + + ;; anonymous ftp password is handled specially since there is an + ;; unwritten rule about how that is used on the Internet. + ((and (efs-anonymous-p user) + efs-generate-anonymous-password) + (if (stringp efs-generate-anonymous-password) + (copy-sequence efs-generate-anonymous-password) + (concat (user-login-name) "@" (efs-system-fqdn)))) + + ;; see if same user has logged in to other hosts; if so then prompt + ;; with the password that was used there. + (t + (let (others defaults passwd) + (unwind-protect + (progn + (setq others (efs-get-passwd-list user host) + defaults (mapcar + (function + (lambda (x) + (cons + (format + "Passwd for %s@%s (same as %s@%s): " + user host (nth 2 x) (nth 1 x)) + (car x)))) + others)) + (setq passwd + (read-passwd + (or defaults + (format "Password for %s@%s: " user host))))) + (while others + (fillarray (car (car others)) 0) + (setq others (cdr others)))) + (or (null passwd) + (and efs-high-security-hosts + (efs-save-match-data + (string-match efs-high-security-hosts + (format "%s@%s" user host)))) + (efs-set-passwd host user passwd)) + passwd)))) + +;;;; ------------------------------------------------------------ +;;;; Account support +;;;; ------------------------------------------------------------ + +(defun efs-get-account (host user &optional minidisk really) + "Given a HOST, USER, and optional MINIDISK return the FTP account password. +If the optional REALLY argument is given, prompts the user if it can't find +one." + (efs-parse-netrc) + (let ((account (if minidisk + (efs-get-hash-entry + (concat (downcase host) "/" user "/" minidisk) + efs-minidisk-hashtable + (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (efs-get-host-user-property host user 'account)))) + (if account + (efs-code-string account) + ;; Do we really want to send the default-account passwd for all + ;; minidisks? + (if (and (stringp efs-default-user) + (string-equal user efs-default-user) + efs-default-account) + efs-default-account + (and really + (let ((acct + (read-passwd + (if minidisk + (format + "Write access password for minidisk %s on %s@%s: " + minidisk user host) + (format + "Account password for %s@%s: " user host))))) + (or (and efs-high-security-hosts + (efs-save-match-data + efs-high-security-hosts + (format "%s@%s" user host))) + (efs-set-account host user minidisk acct)) + acct)))))) + +;;;; ------------------------------------------------------------- +;;;; Special classes of users. +;;;; ------------------------------------------------------------- + +(defun efs-anonymous-p (user) + ;; Returns t if USER should be treated as an anonymous FTP login. + (let ((user (downcase user))) + (or (string-equal user "anonymous") (string-equal user "ftp")))) + + +;;;; ============================================================= +;;;; >5 +;;;; FTP client process, and server responses +;;;; ============================================================= + +;;;; --------------------------------------------------------- +;;;; Support for asynch process queues. +;;;; --------------------------------------------------------- + +(defun efs-add-to-queue (host user item) + "To the end of the command queue for HOST and USER, adds ITEM. +Does nothing if there is no process buffer for HOST and USER." + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-q + (nconc efs-process-q (list item))))))) + +;;;; ------------------------------------------------------- +;;;; Error recovery for the process filter. +;;;; ------------------------------------------------------- + +;;; Could make this better, but it's such an unlikely error to hit. +(defun efs-process-scream-and-yell (line) + (let* ((buff (buffer-name (current-buffer))) + (host (and (string-match "@\\(.*\\)\\*$" buff) + (substring buff (match-beginning 1) (match-end 1))))) + (with-output-to-temp-buffer "*Help*" + (princ + (concat + "efs is unable to identify the following reply code +from the ftp server " host ":\n\n" line " + +Please send a bug report to ange@hplb.hpl.hp.com. +In your report include a transcript of your\n" +buff " buffer.")))) + (error "Unable to identify server code.")) + +(defun efs-error (host user msg) + "Signal \'ftp-error for the FTP connection for HOST and USER. +The error gives the string MSG as text. The process buffer for the FTP +is popped up in another window." + (let ((cur (selected-window)) + (pop-up-windows t) + (buff (get-buffer (efs-ftp-process-buffer host user)))) + (if buff + (progn + (pop-to-buffer buff) + (goto-char (point-max)) + (select-window cur)))) + (signal 'ftp-error (list (format "FTP Error: %s" msg)))) + +;;;; -------------------------------------------------------------------- +;;;; Process filter and supporting functions for handling FTP codes. +;;;; -------------------------------------------------------------------- + +(defun efs-process-handle-line (line proc) + ;; Look at the given LINE from the ftp process PROC and try to catagorize it. + (cond ((string-match efs-xfer-size-msgs line) + (let ((n 1)) + ;; this loop will bomb with an args out of range error at 10 + (while (not (match-beginning n)) + (setq n (1+ n))) + (setq efs-process-xfer-size + (ash (string-to-int (substring line + (match-beginning n) + (match-end n))) + -10)))) + + ((string-match efs-multi-msgs line) + (setq efs-process-result-cont-lines + (concat efs-process-result-cont-lines line "\n"))) + + ((string-match efs-skip-msgs line)) + + ((string-match efs-cmd-ok-msgs line) + (if (string-match efs-cmd-ok-cmds efs-process-cmd) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-pending-msgs line) + (if (string-match "^quote rnfr " efs-process-cmd) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-bytes-received-msgs line) + (if efs-process-server-confused + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-server-confused-msgs line) + (setq efs-process-server-confused t)) + + ((string-match efs-good-msgs line) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line)) + + ((string-match efs-fatal-msgs line) + (set-process-sentinel proc nil) + (delete-process proc) + (setq efs-process-busy nil + efs-process-result 'fatal + efs-process-result-line line)) + + ((string-match efs-failed-msgs line) + (setq efs-process-busy nil + efs-process-result 'failed + efs-process-result-line line)) + + ((string-match efs-unknown-response-msgs line) + (setq efs-process-busy nil + efs-process-result 'weird + efs-process-result-line line) + (efs-process-scream-and-yell line)))) + +(efs-define-fun efs-process-log-string (proc str) + ;; For a given PROCESS, log the given STRING at the end of its + ;; associated buffer. + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (comint-output-filter proc str))))) + +(defun efs-process-filter (proc str) + ;; Build up a complete line of output from the ftp PROCESS and pass it + ;; on to efs-process-handle-line to deal with. + (let ((inhibit-quit t) + (buffer (get-buffer (process-buffer proc))) + (efs-default-directory default-directory)) + + ;; see if the buffer is still around... it could have been deleted. + (if buffer + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + (efs-save-match-data + + ;; handle hash mark printing + (if efs-process-busy + (setq str (efs-process-handle-hash str) + efs-process-string (concat efs-process-string str))) + (efs-process-log-string proc str) + (while (and efs-process-busy + (string-match "\n" efs-process-string)) + (let ((line (substring efs-process-string + 0 + (match-beginning 0)))) + (setq efs-process-string (substring + efs-process-string + (match-end 0))) + ;; If we are in synch with the client, we should + ;; never get prompts in the wrong place. Just to be safe, + ;; chew them off. + (while (string-match efs-process-prompt-regexp line) + (setq line (substring line (match-end 0)))) + (efs-process-handle-line line proc))) + + ;; has the ftp client finished? if so then do some clean-up + ;; actions. + (if (not efs-process-busy) + (progn + (efs-correct-hash-mark-size) + ;; reset process-kill-without-query + (process-kill-without-query proc) + ;; issue the "done" message since we've finished. + (if (and efs-process-msg + (efs-message-p) + (null efs-process-result)) + (progn + + (efs-message "%s...done" efs-process-msg) + (setq efs-process-msg nil))) + + (if (and efs-process-nowait + (null efs-process-cmd-waiting)) + + (progn + ;; Is there a continuation we should be calling? + ;; If so, we'd better call it, making sure we + ;; only call it once. + (if efs-process-continue + (let ((cont efs-process-continue)) + (setq efs-process-continue nil) + (efs-call-cont + cont + efs-process-result + efs-process-result-line + efs-process-result-cont-lines))) + ;; If the cmd was run asynch, run the next + ;; cmd from the queue. For synch cmds, this + ;; is done by efs-send-cmd. For asynch + ;; cmds we don't care about + ;; efs-nested-cmd, since nothing is + ;; waiting for the cmd to complete. If + ;; efs-process-cmd-waiting is t, exit + ;; to let this command run. + (if (and efs-process-q + ;; Be careful to check efs-process-busy + ;; again, because the cont may have started + ;; some new ftp action. + ;; wheels within wheels... + (null efs-process-busy)) + (let ((next (car efs-process-q))) + (setq efs-process-q + (cdr efs-process-q)) + (apply 'efs-send-cmd + efs-process-host + efs-process-user + next)))) + + (if efs-process-continue + (let ((cont efs-process-continue)) + (setq efs-process-continue nil) + (efs-call-cont + cont + efs-process-result + efs-process-result-line + efs-process-result-cont-lines)))) + + ;; Update the mode line + ;; We can't test nowait to see if we changed the + ;; modeline in the first place, because conts + ;; may be running now, which will confuse the issue. + ;; The logic is simpler if we update the modeline + ;; before the cont, but then the user sees the + ;; modeline track the cont execution. It's dizzying. + (if (and (or efs-mode-line-format + efs-ftp-activity-function) + (null efs-process-busy)) + (efs-update-mode-line))))) + + ;; Trim buffer, if required. + (and efs-max-ftp-buffer-size + (zerop efs-process-cmd-counter) + (> (point-max) efs-max-ftp-buffer-size) + (= (point-min) 1) ; who knows, the user may have narrowed. + (null (get-buffer-window (current-buffer))) + (save-excursion + (goto-char (/ efs-max-ftp-buffer-size 2)) + (forward-line 1) + (delete-region (point-min) (point)))))))) + +;;;; ------------------------------------------------------------------ +;;;; Functions for counting hashes and reporting on bytes transferred. +;;;; ------------------------------------------------------------------ + +(defun efs-set-xfer-size (host user bytes) + ;; Set the size of the next FTP transfer in bytes. + (let ((proc (efs-get-process host user))) + (if proc + (let ((buf (process-buffer proc))) + (if buf + (save-excursion + (set-buffer buf) + (setq efs-process-xfer-size (ash bytes -10)))))))) + +(defun efs-guess-incoming-bin-hm-size () + ;; Guess at the hash mark size for incoming binary transfers by taking + ;; the average value for such transfers to other hosts. + (let ((total 0) + (n 0)) + (efs-map-hashtable + (function + (lambda (host hm-size) + (if hm-size (setq total (+ total hm-size) + n (1+ n))))) + efs-host-hashtable + 'incoming-bin-hm-size) + (and (> n 0) (/ total n)))) + +(defun efs-set-hash-mark-unit (host user &optional incoming) + ;; Sets the value of efs-process-hash-mark-unit according to the xfer-type. + ;; efs-hash-mark-unit is the number of bytes represented by a hash mark, + ;; in units of 16. If INCOMING is non-nil, the xfer will be a GET. + (if efs-send-hash + (let ((buff (efs-ftp-process-buffer host user)) + (gate-p (efs-use-gateway-p host t))) + (if buff + (save-excursion + (set-buffer buff) + (setq efs-process-hash-mark-unit + (ash (or + (and incoming (eq efs-process-xfer-type 'image) + (or (efs-get-host-property + host 'incoming-bin-hm-size) + (if gate-p + efs-gateway-incoming-binary-hm-size + efs-incoming-binary-hm-size) + (let ((guess + (efs-guess-incoming-bin-hm-size))) + (and guess + (efs-set-host-property + host 'incoming-bin-hm-size + guess))))) + (if gate-p + efs-gateway-hash-mark-size + efs-hash-mark-size) + 1024) ; make sure that we have some integer + -4))))))) + +(defun efs-correct-hash-mark-size () + ;; Corrects the value of efs-{ascii,binary}-hash-mark-size. + ;; Must be run in the process buffer. + (and efs-send-hash + efs-process-hash-mark-unit + (> efs-process-xfer-size 0) + (< efs-process-xfer-size 524288) ; 2^19, prevent overflows + (> efs-process-hash-mark-count 0) + (or (> efs-process-last-percent 100) + (< (ash (* efs-process-hash-mark-unit + (1+ efs-process-hash-mark-count )) -6) + efs-process-xfer-size)) + (let ((val (ash (/ (ash efs-process-xfer-size 6) + efs-process-hash-mark-count) 4))) + (if (and (eq efs-process-xfer-type 'image) + (>= (length efs-process-cmd) 4) + (string-equal (downcase (substring efs-process-cmd 0 4)) + "get ")) + (efs-set-host-property efs-process-host 'incoming-bin-hm-size val) + (set (if (efs-use-gateway-p efs-process-host t) + 'efs-gateway-hash-mark-size + 'efs-hash-mark-size) + val))))) + +(defun efs-process-handle-hash (str) + ;; Remove hash marks from STRING and display count so far. + (if (string-match "^#+$" str) + (progn + (setq efs-process-hash-mark-count + (+ efs-process-hash-mark-count + (- (match-end 0) (match-beginning 0)))) + (and + efs-process-msg + efs-process-hash-mark-unit + (not (and efs-process-nowait + (or (eq efs-verbose 0) + (eq (selected-window) (minibuffer-window))))) + (efs-message-p) + (let* ((big (> efs-process-hash-mark-count 65536)) ; 2^16 + (kbytes (if big + (* efs-process-hash-mark-unit + (ash efs-process-hash-mark-count -6)) + (ash (* efs-process-hash-mark-unit + efs-process-hash-mark-count) + -6)))) + (if (zerop efs-process-xfer-size) + (or (zerop kbytes) + (efs-message "%s...%dk" efs-process-msg kbytes)) + (let ((percent (if big + (/ (* 100 (ash kbytes -7)) + (ash efs-process-xfer-size -7)) + (/ (* 100 kbytes) efs-process-xfer-size)))) + ;; Don't display %'s betwwen 100 and 110 + (and (> percent 100) (< percent 110) (setq percent 100)) + ;; cut out the redisplay of identical %-age messages. + (or (eq percent efs-process-last-percent) + (progn + (setq efs-process-last-percent percent) + (efs-message "%s...%d%%" efs-process-msg percent))))))) + (concat (substring str 0 (match-beginning 0)) + (and (/= (length str) (match-end 0)) + (substring str (1+ (match-end 0)))))) + str)) + +;;;; ------------------------------------------------------------------ +;;;; Keeping track of the number of active background connections. +;;;; ------------------------------------------------------------------ + +(defun efs-ftp-processes-active () + ;; Return the number of FTP processes busy. + (save-excursion + (length + (delq nil + (mapcar + (function + (lambda (buff) + (set-buffer buff) + (and (boundp 'efs-process-busy) + efs-process-busy))) + (buffer-list)))))) + +(defun efs-update-mode-line () + ;; Updates the mode with FTP activity, and runs `efs-ftp-activity-function'. + (let ((num (efs-ftp-processes-active))) + (if efs-mode-line-format + (progn + (if (zerop num) + (setq efs-mode-line-string "") + (setq efs-mode-line-string (format efs-mode-line-format num))) + ;; fake emacs into re-calculating all the mode lines. + (save-excursion (set-buffer (other-buffer))) + (set-buffer-modified-p (buffer-modified-p)))) + (if efs-ftp-activity-function + (funcall efs-ftp-activity-function num)))) + +(defun efs-display-ftp-activity () + "Displays the number of active background ftp sessions. +Uses the variable `efs-mode-line-format' to determine how this will be +displayed." + (interactive) + (or (memq 'efs-mode-line-string global-mode-string) + (if global-mode-string + (nconc global-mode-string '(efs-mode-line-string)) + (setq global-mode-string '("" efs-mode-line-string))))) + +;;;; ------------------------------------------------------------------- +;;;; Expiring inactive ftp buffers. +;;;; ------------------------------------------------------------------- + +(defun efs-start-polling () + ;; Start polling FTP buffers, to look for idle ones. + (or (null efs-expire-ftp-buffers) + (let ((proc (get-process "efs poll"))) + (or (and proc (eq (process-status proc) 'run)))) + (let ((default-directory exec-directory) + (process-connection-type nil) + new-proc) + (condition-case nil + (delete-process "efs poll") + (error nil)) + (setq new-proc (start-process + "efs poll" nil + (concat exec-directory "wakeup") + (int-to-string efs-ftp-buffer-poll-time))) + (set-process-filter new-proc (function efs-expire-ftp-buffers-filter)) + (process-kill-without-query new-proc)))) + +(defun efs-connection-visited-p (host user) + ;; Returns t if there are any buffers visiting files on HOST and USER. + (save-excursion + (let ((list (buffer-list)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (visited nil) + parsed) + (setq host (downcase host)) + (if case-fold (setq user (downcase user))) + (while list + (set-buffer (car list)) + (if (or (and buffer-file-name + (setq parsed (efs-ftp-path buffer-file-name)) + (string-equal host (downcase (car parsed))) + (string-equal user (if case-fold + (downcase (nth 1 parsed)) + (nth 1 parsed)))) + (and (boundp 'dired-directory) + (stringp dired-directory) + efs-dired-host-type + (setq parsed (efs-ftp-path dired-directory)) + (string-equal host (downcase (car parsed))) + (string-equal user (if case-fold + (downcase (nth 1 parsed)) + (nth 1 parsed))))) + (setq visited t + list nil) + (setq list (cdr list)))) + visited))) + +(defun efs-expire-ftp-buffers-filter (proc string) + ;; Check all ftp buffers, and kill them if they have been inactive + ;; for the minimum of efs-ftp-buffer-expire-time and their local + ;; time out time. + (if efs-expire-ftp-buffers + (let ((list (buffer-list)) + new-alist) + (save-excursion + (while list + (set-buffer (car list)) + (if (eq major-mode 'efs-mode) + (let* ((proc (get-buffer-process (current-buffer))) + (proc-p (and proc (memq (process-status proc) + '(run open))))) + (if (or efs-ftp-buffer-expire-time + efs-process-idle-time + (null proc-p)) + (let ((elt (assq (car list) efs-ftp-buffer-alist)) + (wind-p (get-buffer-window (car list)))) + (if (or (null elt) (buffer-modified-p) + efs-process-busy wind-p) + (progn + (setq new-alist (cons (cons (car list) 0) + new-alist)) + (or wind-p (set-buffer-modified-p nil))) + (let ((idle (+ (cdr elt) + efs-ftp-buffer-poll-time))) + (if (and proc-p + (< idle + (if efs-ftp-buffer-expire-time + (if efs-process-idle-time + (min efs-ftp-buffer-expire-time + efs-process-idle-time) + efs-ftp-buffer-expire-time) + efs-process-idle-time))) + (progn + (setq new-alist (cons (cons (car list) idle) + new-alist)) + (set-buffer-modified-p nil)) + ;; If there are still buffers for host & user, + ;; don't wipe the cache. + (and proc + (efs-connection-visited-p + efs-process-host efs-process-user) + (set-process-sentinel proc nil)) + (kill-buffer (car list))))))))) + (setq list (cdr list)))) + (setq efs-ftp-buffer-alist new-alist)) + (condition-case nil + (delete-process "efs poll") + (error nil)))) + +;;;; ------------------------------------------------------------------- +;;;; When the FTP client process dies... +;;;; ------------------------------------------------------------------- + +(defun efs-process-sentinel (proc str) + ;; When ftp process changes state, nuke all file-entries in cache. + (let ((buff (process-buffer proc))) + ;; If the client dies, make sure that efs doesn't think that + ;; there is a running process. + (save-excursion + (condition-case nil + (progn + (set-buffer buff) + (setq efs-process-busy nil)) + (error nil))) + (let ((parsed (efs-parse-proc-name proc))) + (if parsed + (progn + (apply 'efs-wipe-file-entries parsed) + (apply 'efs-wipe-from-ls-cache parsed)))) + (if (or efs-mode-line-format efs-ftp-activity-function) + (efs-update-mode-line)))) + +(defun efs-kill-ftp-process (buffer) + "Kill an FTP connection and its associated process buffer. +If the BUFFER's visited file name or default-directory is an efs remote +file name, it is the connection for that file name that is killed." + (interactive "bKill FTP process associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (save-excursion + (set-buffer buffer) + (if (eq major-mode 'efs-mode) + (kill-buffer buffer) + (let ((file (or (buffer-file-name) default-directory))) + (if file + (let ((parsed (efs-ftp-path (expand-file-name file)))) + (if parsed + (let ((host (nth 0 parsed)) + (user (nth 1 parsed))) + (kill-buffer + (efs-ftp-process-buffer host user)))))))))) + +(defun efs-close-ftp-process (buffer) + "Close an FTP connection. +This kills the FTP client process, but unlike `efs-kill-ftp-process' this +neither kills the process buffer, nor deletes cached data for the connection." + (interactive "bClose FTP process associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (save-excursion + (set-buffer buffer) + (if (eq major-mode 'efs-mode) + (let ((process (get-buffer-process buffer))) + (if process + (progn + (set-process-sentinel process nil) + (setq efs-process-busy nil + efs-process-q nil) + (if (or efs-mode-line-format efs-ftp-activity-function) + (efs-update-mode-line)) + (delete-process process)))) + (let ((file (or (buffer-file-name) default-directory))) + (if file + (let ((parsed (efs-ftp-path (expand-file-name file)))) + (if parsed + (let ((process (get-process + (format "*ftp %s@%s*" + (nth 1 parsed) (car parsed))))) + (if process + (progn + (set-buffer (process-buffer process)) + (set-process-sentinel process nil) + (setq efs-process-busy nil + efs-process-q nil) + (if (or efs-mode-line-format + efs-ftp-activity-function) + (efs-update-mode-line)) + (delete-process process))))))))))) + +(defun efs-ping-ftp-connection (buffer) + "Ping a connection by sending a NOOP command. +Useful for waking up a possible expired connection." + (interactive "bPing FTP connection associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (efs-save-buffer-excursion + (set-buffer buffer) + (let (file host user parsed) + (if (or (and (eq major-mode 'efs-mode) + (setq host efs-process-host + user efs-process-user)) + (and (setq file (or (buffer-file-name) default-directory)) + (setq parsed (efs-ftp-path file)) + (setq host (car parsed) + user (nth 1 parsed)))) + (or (car + (efs-send-cmd + host user '(quote noop) + (format "Pinging connection %s@%s" user host))) + (message "Connection %s@%s is alive." user host)))))) + +(defun efs-display-ftp-process-buffer (buffer) + "Displays the FTP process buffer associated with the current buffer." + (interactive "bDisplay FTP buffer associated with buffer: ") + (if (null buffer) (setq buffer (current-buffer))) + (let ((file (or (buffer-file-name) default-directory)) + parsed proc-buffer) + (if (and file (setq parsed (efs-ftp-path file)) + (setq proc-buffer (get-buffer (efs-ftp-process-buffer + (car parsed) + (nth 1 parsed))))) + (display-buffer proc-buffer) + (error "Buffer %s not associated with an FTP process" buffer)))) + +;;;; ------------------------------------------------------------------- +;;;; Starting the FTP client process +;;;; ------------------------------------------------------------------- + +(defun efs-ftp-process-buffer (host user) + "Return name of the process buffer for ftp process for HOST and USER." + ;; Host names on the internet are case-insensitive. + (format efs-ftp-buffer-format user (downcase host))) + +(defun efs-pty-check (proc threshold) + ;; Checks to see if PROC is a pty. Beware, it clobbers the process + ;; filter, so run this before you set the filter. + ;; THRESHOLD is an integer to tell it how long to wait for output. + (sit-for 0) ; Update the display before doing any waiting. + (let ((efs-pipe-p t) + (n 0)) + (set-process-filter proc (function (lambda (proc string) + (setq efs-pipe-p nil)))) + (while (and (< n threshold) efs-pipe-p) + (accept-process-output) + (setq n (1+ n))) + (if efs-pipe-p + (progn + (sit-for 0) ; update display + ;; Use a sleep-for as I don't want pty-checking to depend + ;; on pending input. + (sleep-for efs-pty-check-retry-time))) + (accept-process-output) + (if efs-pipe-p + (if (or noninteractive + (progn + ;; in case the user typed something during the wait. + (discard-input) + (y-or-n-p + (format "%s seems not a pty. Kill? " proc)))) + (progn + (kill-buffer (process-buffer proc)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal 'quit nil)))) + ;; Need to send a \n to make sure, because sometimes we get the startup + ;; prompt from a pipe. + (sit-for 0) + (process-send-string proc "\n") + (setq efs-pipe-p t + n 0) + (while (and (< n threshold) efs-pipe-p) + (accept-process-output) + (setq n (1+ n))) + (if efs-pipe-p + (progn + (sit-for 0) + (sleep-for efs-pty-check-retry-time))) + (accept-process-output) + (if (and efs-pipe-p + (or noninteractive + (progn + ;; in case the user typed something during the wait. + (discard-input) + (y-or-n-p + (format "%s seems not a pty. Kill? " proc))))) + (progn + (kill-buffer (process-buffer proc)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal 'quit nil))))))) + +(defun efs-start-process (host user name) + "Spawn a new ftp process ready to connect to machine HOST as USER. +If HOST is only ftp-able through a gateway machine then spawn a shell +on the gateway machine to do the ftp instead. NAME is the name of the +process." + (let* ((use-gateway (efs-use-gateway-p host)) + (buffer (get-buffer-create (efs-ftp-process-buffer host user))) + (process-connection-type t) + (opaque-p (memq use-gateway efs-opaque-gateways)) + proc) + (save-excursion + (set-buffer buffer) + (efs-mode host user (if opaque-p + efs-gateway-ftp-prompt-regexp + efs-ftp-prompt-regexp))) + (cond + ((null use-gateway) + (message "Opening FTP connection to %s..." host) + (setq proc (apply 'start-process name buffer efs-ftp-program-name + efs-ftp-program-args))) + ((eq use-gateway 'interactive) + (setq proc (efs-gwp-start host user name))) + ((eq use-gateway 'remsh) + (message "Opening FTP connection to %s via %s..." host efs-gateway-host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (append (list efs-gateway-host) + (nth 2 efs-gateway-type) + (list (nth 3 efs-gateway-type)) + (nth 4 efs-gateway-type))))) + ((memq use-gateway '(proxy raptor interlock kerberos)) + (message "Opening FTP connection to %s via %s..." host efs-gateway-host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (nth 2 efs-gateway-type)))) + ((eq use-gateway 'local) + (message "Opening FTP connection to %s..." host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (nth 2 efs-gateway-type)))) + ((error "Never heard of gateway type %s" use-gateway))) + (process-kill-without-query proc) + (if opaque-p + (accept-process-output proc) + (if efs-pty-check-threshold + (efs-pty-check proc efs-pty-check-threshold) + (accept-process-output proc))) + (set-process-sentinel proc (function efs-process-sentinel)) + (set-process-filter proc (function efs-process-filter)) + (efs-start-polling) + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + proc)) + +(defun efs-get-process-internal (host user) + ;; Get's the first process for HOST and USER. If HOST runs a + ;; a case insignificant OS, then case is not considered in USER. + (let ((list (process-list)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (len (+ (length host) (length user) 7)) + fmt name found) + (setq host (downcase host)) + (if case-fold (setq user (downcase user))) + (while (and (not found) list) + (setq name (process-name (car list))) + (if (and (= (length name) len) + (string-equal (substring name 0 5) "*ftp ") + (string-equal + (if case-fold (downcase (substring name 5)) (substring name 5)) + (or fmt (setq fmt (format "%s@%s*" user host)))) + (memq (process-status (car list)) '(run open))) + (setq found (car list)) + (setq list (cdr list)))) + found)) + +;; efs-guess-host-type calls this +;; function recursively. The (if (and proc... avoids an infinite +;; loop. We should make sure that this won't hang things if the +;; connection goes wrong. + +(defun efs-get-process (host user) + "Return the process object for the FTP process for HOST and USER. +Create a new process if needed." + + (let ((proc (efs-get-process-internal host user))) + (if (and proc (memq (process-status proc) '(run open))) + proc + + ;; Make sure that the process isn't around in some strange state. + + (setq host (downcase host)) + (let ((name (concat "*ftp " user "@" host "*"))) + (if proc (condition-case nil (delete-process proc) (error nil))) + + ;; grab a suitable process. + (setq proc (efs-start-process host user name)) + + (efs-save-match-data + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + + ;; Run any user-specified hooks. + (run-hooks 'efs-ftp-startup-hook) + + ;; login to FTP server. + (efs-login host user proc) + + ;; Beware, the process may have died if the login went bad. + (if (memq (process-status proc) '(run open)) + + (progn + ;; Tell client to send back hash-marks as progress. It isn't + ;; usually fatal if this command fails. + (efs-guess-hash-mark-size proc) + + ;; Run any user startup functions + (let ((alist efs-ftp-startup-function-alist) + (case-fold-search t)) + (while alist + (if (string-match (car (car alist)) host) + (progn + (funcall (cdr (car alist)) host user) + (setq alist nil)) + (setq alist (cdr alist))))) + + ;; Guess at the host type. + (efs-guess-host-type host user) + + ;; Check the idle time. + (efs-check-idle host user) + + proc) + + ;; Hopefully a recursive retry worked. + (or (efs-get-process-internal host user) + (error "No FTP process for %s@%s" user host))))))))) + +(defun efs-guess-hash-mark-size (proc) + ;; Doesn't run efs-save-match-data. You must do that yourself. + (if efs-send-hash + (save-excursion + (set-buffer (process-buffer proc)) + (let ((line (nth 1 (efs-raw-send-cmd proc "hash"))) + (gate-p (efs-use-gateway-p efs-process-host t))) + ;; Don't guess if the hash-mark-size is already set. + (or (if gate-p efs-gateway-hash-mark-size efs-hash-mark-size) + (if (string-match efs-hash-mark-msgs line) + (let ((size (substring line (match-beginning 1) + (match-end 1)))) + (if (string-match "^[0-9]+$" size) + (set (if gate-p + 'efs-gateway-hash-mark-size + 'efs-hash-mark-size) + (string-to-int size)))))))))) + +;;;; ------------------------------------------------------------ +;;;; Simple FTP process shell support. +;;;; ------------------------------------------------------------ + +(defun efs-mode (host user prompt) + "Major mode for interacting with an FTP process. +The user interface for sending commands to the FTP process is `comint-mode'. +For more information see the documentation for `comint-mode'. This command +is not intended for interactive use. +Takes arguments: HOST USER PROMPT + +Runs efs-mode-hook if it is not nil. + +Key map: +\\{comint-mode-map}" + (let ((proc (get-buffer-process (current-buffer)))) + ;; Running comint-mode will kill-all-local-variables. + (comint-mode) + ;; All these variables are buffer local. + (setq major-mode 'efs-mode + mode-name "efs" + default-directory (file-name-directory efs-tmp-name-template) + comint-prompt-regexp prompt + efs-process-host host + efs-process-user user + efs-process-prompt-regexp prompt) + (set (make-local-variable 'paragraph-start) comint-prompt-regexp) + ;; Old versions of comint don't have this. It does no harm for + ;; the newer ones. + (set (make-local-variable 'comint-last-input-start) (make-marker)) + (goto-char (point-max)) + ;; in case there is a running process + (if proc (set-marker (process-mark proc) (point))) + (run-hooks 'efs-mode-hook))) + + +;;;; ============================================================= +;;;; >6 +;;;; Sending commands to the FTP server. +;;;; ============================================================= + +;;;; ------------------------------------------------------------- +;;;; General purpose functions for sending commands. +;;;; ------------------------------------------------------------- + +(defun efs-raw-send-cmd (proc cmd &optional msg pre-cont cont nowait) +;; Low-level routine to send the given ftp CMD to the ftp PROCESS. +;; MSG is an optional message to output before and after the command. +;; If PRE-CONT is non-nil, it is called immediately after execution +;; of the command starts, but without waiting for it to finish. +;; If CONT is non-NIL then it is either a function or a list of function and +;; some arguments. The function will be called when the ftp command has +;; completed. +;; If CONT is NIL then this routine will return \( RESULT . LINE \) where +;; RESULT is whether the command was successful, and LINE is the line from +;; the FTP process that caused the command to complete. +;; If NOWAIT is nil then we will wait for the command to complete before +;; returning. If NOWAIT is 0, then we will wait until the command starts, +;; executing before returning. NOWAIT of 1 is like 0, except that the modeline +;; will indicate an asynch FTP command. +;; If NOWAIT has any other value, then we will simply queue the +;; command. In all cases, CONT will still be called + + (if (memq (process-status proc) '(run open)) + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + + (if efs-process-busy + ;; This function will always wait on a busy process. + ;; Queueing is done by efs-send-cmd. + (let ((efs-process-cmd-waiting t)) + (efs-kbd-quit-protect proc + (while efs-process-busy + (accept-process-output))))) + + (setq efs-process-string "" + efs-process-result-line "" + efs-process-result-cont-lines "" + efs-process-busy t + efs-process-msg (and efs-verbose msg) + efs-process-continue cont + efs-process-server-confused nil + efs-process-nowait nowait + efs-process-hash-mark-count 0 + efs-process-last-percent -1 + efs-process-xfer-size 0 + efs-process-cmd-counter (% (1+ efs-process-cmd-counter) 16)) + (process-kill-without-query proc t) + (and efs-process-msg + (efs-message-p) + (efs-message "%s..." efs-process-msg)) + (goto-char (point-max)) + (move-marker comint-last-input-start (point)) + (move-marker comint-last-input-end (point)) + ;; don't insert the password into the buffer on the USER command. + (efs-save-match-data + (if (string-match efs-passwd-cmds cmd) + (insert (setq efs-process-cmd + (substring cmd 0 (match-end 0))) + " Turtle Power!\n") + (setq efs-process-cmd cmd) + (insert cmd "\n"))) + (process-send-string proc (concat cmd "\n")) + (set-marker (process-mark proc) (point)) + ;; Update the mode-line + (if (and (or efs-mode-line-format efs-ftp-activity-function) + (memq nowait '(t 1))) + (efs-update-mode-line)) + (if pre-cont + (let ((efs-nested-cmd t)) + (save-excursion + (apply (car pre-cont) (cdr pre-cont))))) + (prog1 + (if nowait + nil + ;; hang around for command to complete + ;; Some clients die after the command is sent, if the server + ;; times out. Don't wait on dead processes. + (efs-kbd-quit-protect proc + (while (and efs-process-busy + ;; Need to recheck nowait, since it may get reset + ;; in a cont. + (null efs-process-nowait) + (memq (process-status proc) '(run open))) + (accept-process-output proc))) + + ;; cont is called by the process filter + (if cont + ;; Return nil if a cont was called. + ;; Can't return process-result + ;; and process-line since executing + ;; the cont may have changed + ;; the state of the process buffer. + nil + (list efs-process-result + efs-process-result-line + efs-process-result-cont-lines))) + + ;; If the process died, the filter would have never got the chance + ;; to call the cont. Try to jump start things. + + (if (and (not (memq (process-status proc) '(run open))) + (string-equal efs-process-result-line "") + cont + (equal cont efs-process-continue)) + (progn + (setq efs-process-continue nil + efs-process-busy nil) + ;; The process may be in some strange state. Get rid of it. + (condition-case nil (delete-process proc) (error nil)) + (efs-call-cont cont 'fatal "" ""))))) + + (error "FTP process %s has died." (process-name proc)))) + +(efs-defun efs-quote-string nil (string &optional not-space) + "Quote any characters in STRING that may confuse the ftp process. +If NOT-SPACE is non-nil, then blank characters are not quoted, because +it is assumed that the string will be surrounded by \"'s." + (apply (function concat) + (mapcar (function + (lambda (char) + (if (or (< char ?\ ) + (and (null not-space) (= char ?\ )) + (> char ?\~) + (= char ?\") + (= char ?\\)) + (vector ?\\ char) + (vector char)))) + string))) + +(efs-defun efs-fix-path nil (path &optional reverse) + "Convert PATH from a unix format to a non-unix format. +If optional REVERSE, convert in the opposite direction." + (identity path)) + +(efs-defun efs-fix-dir-path nil (dir-path) + "Convert DIR-PATH from unix format to a non-unix format for a dir listing" + ;; The default def runs for dos-distinct, ka9q, and all the unix's. + ;; To be more careful about distinguishing dirs from plain files, + ;; we append a ".". + (let ((len (length dir-path))) + (if (and (not (zerop len)) (= (aref dir-path (1- len)) ?/)) + (concat dir-path ".") + dir-path))) + +(defun efs-send-cmd (host user cmd + &optional msg pre-cont cont nowait noretry) + "Find an ftp process connected to HOST logged in as USER and send it CMD. +MSG is an optional status message to be output before and after issuing the +command. + +See the documentation for efs-raw-send-cmd for a description of CONT, PRE-CONT +and NOWAIT. Normally, if the command fails it is retried. If NORETRY is +non-nil, this is not done." + ;; Handles conversion to remote pathname syntax and remote ls option + ;; capability. Also, sends umask if nec. + + (let ((proc (efs-get-process host user))) + + (if (and + (eq nowait t) + (save-excursion + (set-buffer (process-buffer proc)) + (or efs-process-busy + efs-process-cmd-waiting))) + + (progn + (efs-add-to-queue + host user + ;; Not nec. to store host and user, because the queue is for + ;; a specific host user pair anyway. Because the queue is always + ;; examined when efs-process-busy + ;; is nil, it should be impossible to get into a loop + ;; where we keep re-queueing over and over. To be on the safe + ;; side, store nowait as 1. + (list cmd msg pre-cont cont 1 noretry)) + nil) + + ;; Send a command. + + (let (cmd-string afsc-result afsc-line afsc-cont-lines) + + (let ((efs-nested-cmd t) + (cmd0 (car cmd)) + (cmd1 (nth 1 cmd)) + (cmd2 (nth 2 cmd)) + (cmd3 (nth 3 cmd))) + + (cond + + ((eq cmd0 'quote) + ;; QUOTEd commands + (cond + + ((eq cmd1 'site) + ;; SITE commands + (cond + ((memq cmd2 '(umask idle dos exec nfs group gpass)) + ;; For UMASK cmd3 = value of umask + ;; For IDLE cmd3 = idle setting, or nil if we're querying. + ;; For DOS and NFS cmd3 is nil. + ;; For EXEC cmd3 is the command to be exec'ed -- a string. + (if cmd3 (setq cmd3 (concat " " cmd3))) + (setq cmd-string (concat "quote site " (symbol-name cmd2) + cmd3))) + ((eq cmd2 'chmod) + (let* ((host-type (efs-host-type host user)) + (cmd4 (efs-quote-string + host-type (efs-fix-path host-type (nth 4 cmd))))) + (setq cmd-string (concat "quote site chmod " cmd3 " " + cmd4)))) + (t (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ((memq cmd1 '(pwd xpwd syst pasv noop)) + (setq cmd-string (concat "quote " (symbol-name cmd1)))) + + ;; PORT command (cmd2 is IP + port address) + ((eq cmd1 'port) + (setq cmd-string (concat "quote port " cmd2))) + + ((memq cmd1 '(appe retr)) + (let ((host-type (efs-host-type host user))) + ;; Set an xfer type + (if cmd3 (efs-set-xfer-type host user cmd3 t)) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote " (symbol-name cmd1) " " + cmd2)))) + + ((eq cmd1 'stor) + (let ((host-type (efs-host-type host user))) + (if (memq host-type efs-unix-host-types) + (efs-set-umask host user)) + ;; Set an xfer type + (if cmd3 (efs-set-xfer-type host user cmd3 t)) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote stor " cmd2)))) + + ((memq cmd1 '(size mdtm rnfr)) + (let ((host-type (efs-host-type host user))) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote " + (symbol-name cmd1) " " cmd2)))) + + ((memq cmd1 '(pass user)) + (setq cmd-string (concat "quote " (symbol-name cmd1) " " cmd2))) + + (t + (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ;; TYPE command + ((eq cmd0 'type) + (setq cmd-string (concat "type " (symbol-name cmd1)))) + + ;; DIR command + ;; cmd == 'dir "remote-path" "local-path" "ls-switches" + ((memq cmd0 '(dir nlist)) + (let ((host-type (efs-host-type host user)) + (listing-type (efs-listing-type host user))) + (setq cmd1 (efs-fix-dir-path host-type cmd1)) + (cond + ((memq listing-type efs-nlist-listing-types) + (setq cmd-string (concat efs-nlist-cmd " " + (efs-quote-string host-type cmd1) + " " cmd2))) + ((or (memq host-type efs-dumb-host-types) + (null cmd3)) + (setq cmd-string (format "%s %s %s" + (if (eq cmd0 'nlist) + efs-nlist-cmd + "dir") + (efs-quote-string host-type cmd1) + cmd2))) + ((setq cmd-string + (format "%s \"%s %s\" %s" + (if (eq cmd0 'nlist) + efs-nlist-cmd + "ls") + cmd3 (efs-quote-string host-type cmd1 t) + ;; cmd2 is a temp file, not nec. to quote. + cmd2)))))) + + ;; First argument is the remote pathname + ((memq cmd0 '(delete mkdir rmdir cd)) + (let ((host-type (efs-host-type host user))) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd-string (concat (symbol-name cmd0) " " cmd1)))) + + ;; GET command + ((eq cmd0 'get) + (let ((host-type (efs-host-type host user))) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user t) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd2 (efs-quote-string host-type cmd2) + cmd-string (concat "get " cmd1 " " cmd2)))) + + ;; PUT command + ((eq cmd0 'put) + (let ((host-type (efs-host-type host user))) + (if (memq host-type efs-unix-host-types) + (efs-set-umask host user)) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd1 (efs-quote-string host-type cmd1) + cmd-string (concat "put " cmd1 " " cmd2)))) + + ;; APPEND command + ((eq cmd0 'append) + (let ((host-type (efs-host-type host user))) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd1 (efs-quote-string host-type cmd1) + cmd-string (concat "append " cmd1 " " cmd2)))) + + ;; CHMOD command + ((eq cmd0 'chmod) + (let ((host-type (efs-host-type host user))) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "chmod " cmd1 " " cmd2)))) + + ;; Both arguments are remote pathnames + ((eq cmd0 'rename) + (let ((host-type (efs-host-type host user))) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "rename " cmd1 " " cmd2)))) + + (t + (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ;; Actually send the resulting command. + ;; Why do we use this complicated binding of afsc-{result,line}, + ;; rather then use the fact that efs-raw-send-cmd returns? + ;; Because efs-raw-send-cmd returns the result of the first + ;; attempt only. efs-send-cmd should return the result of + ;; the retry, if one was necessary. + ;; Maybe it would be better if efs-raw-send-cmd returned + ;; the result of cont, if nowait was nil? Or maybe still return + ;; \(result line \)? As long as nowait is nil, it should + ;; return something useful. + + ;; Beware, if some of the above FTP commands had to restart + ;; the process, PROC won't be set to the right process object. + (setq proc (efs-get-process host user)) + + (efs-raw-send-cmd + proc + cmd-string + msg + pre-cont + (efs-cont (result line cont-lines) (host user proc cmd msg pre-cont + cont nowait noretry) + (cond ((and (null noretry) (eq result 'fatal)) + (let ((retry + (efs-send-cmd + host user cmd msg pre-cont cont + (if (eq nowait t) 1 nowait) t))) + (or cont nowait + (setq afsc-result (car retry) + afsc-line (nth 1 retry) + afsc-cont-lines (nth 2 retry))))) + ((and (eq result 'failed) + (or (memq (car cmd) '(append rename put)) + (and (eq (car cmd) 'quote) + (eq (nth 1 cmd) 'stor))) + (efs-save-match-data + (string-match efs-write-protect-msgs line))) + (let ((retry (efs-write-recover + (efs-host-type host) + line cont-lines host user cmd msg pre-cont + cont nowait noretry))) + (or cont nowait + (setq afsc-result (car retry) + afsc-line (nth 1 retry) + afsc-cont-lines (nth 2 retry))))) + + (t (if cont + (efs-call-cont cont result line cont-lines) + (or nowait + (setq afsc-result result + afsc-line line + afsc-cont-lines cont-lines)))))) + nowait) + + (prog1 + (if (or nowait cont) + nil + (list afsc-result afsc-line afsc-cont-lines)) + + ;; Check the queue + (or nowait + efs-nested-cmd + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (if efs-process-q + (let ((next (car efs-process-q))) + (setq efs-process-q (cdr efs-process-q)) + (apply 'efs-send-cmd host user next)))))))))))) + +(efs-defun efs-write-recover nil + (line cont-lines host user cmd msg pre-cont cont nowait noretry) + "Called when a write command fails with `efs-write-protect-msgs'. +Should return \(result line cont-lines\), like `efs-raw-send-cmd'." + ;; This default version doesn't do anything. + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (if nowait nil (list 'failed line cont-lines)))) + +;;;; --------------------------------------------------------------------- +;;;; The login sequence. (The follows RFC959 rather tightly. If a server +;;;; can't even get the login codes right, it is +;;;; pretty much scrap metal.) +;;;; --------------------------------------------------------------------- + +(defun efs-nslookup-host (host) + "Attempt to resolve the given HOSTNAME using nslookup if possible." + (interactive "sHost: ") + (if efs-nslookup-program + (let* ((default-directory exec-directory) + (default-major-mode 'fundamental-mode) + (process-connection-type nil) + (proc (start-process " *nslookup*" " *nslookup*" + efs-nslookup-program host)) + (res host)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (let ((quit-flag nil) + (inhibit-quit nil)) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc))) + (goto-char (point-min)) + (if (re-search-forward + "Name:.*\nAddress\\(es\\)?: *\\([.0-9]+\\)$" nil t) + (setq res (buffer-substring (match-beginning 2) + (match-end 2)))) + (kill-buffer (current-buffer))) + (if (interactive-p) + (message "%s: %s" host res)) + res) + (if (interactive-p) + (message + "No nslookup program. See the variable efs-nslookup-program.")) + host)) + +(defun efs-login (host user proc) + "Connect to the FTP-server on HOST as USER. +PROC is the process to the FTP-client. Doesn't call efs-save-match-data. +You must do that yourself." + (let ((gate (efs-use-gateway-p host))) + (if (eq gate 'kerberos) + (progn + (setq proc (efs-kerberos-login host user proc)) + (efs-login-send-user host user proc gate)) + (let ((to (if (memq gate '(proxy local raptor)) + efs-gateway-host + host)) + port cmd result) + (if (string-match "#" to) + (setq port (substring to (match-end 0)) + to (substring to 0 (match-beginning 0)))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (setq to (efs-nslookup-host to))) + (setq cmd (concat "open " to)) + (if port (setq cmd (concat cmd " " port))) + + ;; Send OPEN command. + (setq result (efs-raw-send-cmd proc cmd nil)) + + (and (eq gate 'interlock) (string-match "^331 " (nth 1 result)) + (setq result (efs-login-send-pass + efs-gateway-host + (efs-get-user efs-gateway-host) proc))) + + ;; Analyze result of OPEN. + (if (car result) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "OPEN request failed: " + (nth 1 result)))) + (efs-login-send-user host user proc gate)))))) + +(defun efs-login-send-user (host user proc &optional gate retry) + "Send user command to HOST and USER. PROC is the ftp client process. +Optional argument GATE specifies which type of gateway is being used. +RETRY argument specifies to try twice if we get a 421 response." + (let ((cmd (cond + ((memq gate '(local proxy interlock)) + (format "quote USER \"%s\"@%s" user + (if (and efs-nslookup-on-connect + (string-match "[^0-9.]" host)) + (efs-nslookup-host host) + host))) + ((eq gate 'raptor) + (format "quote USER \"%s\"@%s %s" user + (if (and efs-nslookup-on-connect + (string-match "[^0-9.]" host)) + (efs-nslookup-host host) + host) + (nth 3 efs-gateway-type))) + ((eq gate 'kerberos) + (let ((to host) + port) + (if (string-match "#" host) + (progn + (setq to (substring host 0 (match-beginning 0)) + port (substring host (match-end 0))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (efs-nslookup-host to)) + (setq to (concat to "@" port)))) + (format "quote user \"%s\"@%s" user to))) + (t + (format "quote user \"%s\"" user)))) + (msg (format "Logging in as user %s%s..." user + (if (memq gate '(proxy local raptor kerberos)) + (concat "@" host) ""))) + result code) + + ;; Send the message by hand so that we can report on the size + ;; of the MOTD. + (message msg) + + ;; Send USER command. + (setq result (efs-raw-send-cmd proc cmd nil)) + + ;; Analyze result of USER (this follows RFC959 strictly) + (if (< (length (nth 1 result)) 4) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user + (concat "USER request failed: " (nth 1 result)))) + + (setq code (substring (nth 1 result) 0 4)) + (cond + + ((string-equal "331 " code) + ;; Need password + (setq result (efs-login-send-pass host user proc gate))) + + ((string-equal "332 " code) + ;; Need an account, but no password + (setq result (efs-login-send-acct host user proc gate))) + + ((null (car result)) + ;; logged in proceed + nil) + + ((and (or (string-equal "530 " code) (string-equal "421 " code)) + (efs-anonymous-p user) + (or (string-match efs-too-many-users-msgs (nth 1 result)) + (string-match efs-too-many-users-msgs (nth 2 result)))) + (if (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (y-or-n-p (format + "Too many users for %s@%s. Try again? " + user host))) + (progn + ;; Set result to nil if we are doing a retry, so done + ;; message only gets sent once. + (setq result nil) + (if (string-equal code "530 ") + (efs-login-send-user host user proc gate t) + (efs-get-process host user))) + (signal 'quit nil))) + + ((and retry (string-equal code "421 ")) + (setq result nil) + (efs-get-process host user)) + + (t ; bombed + (condition-case nil (delete-process proc) (error nil)) + ;; Wrong username? + (efs-set-user host nil) + (efs-error host user + (concat "USER request failed: " (nth 1 result))))) + (and (null (car result)) + (stringp (nth 2 result)) + (message "%sdone%s" msg + (let ((n (efs-occur-in-string ?\n (nth 2 result)))) + (if (> n 1) + (format "; MOTD of %d lines" n) + ""))))))) + +(defun efs-login-send-pass (host user proc &optional gate) + "Sends password to HOST and USER. PROC is the ftp client process. +Doesn't call efs-save-match data. You must do that yourself." + ;; Note that efs-get-password always returns something. + ;; It prompts the user if necessary. Even if the returned password is + ;; \"\", send it, because we wouldn't be running this function + ;; if the server wasn't insisting on a password. + (let* ((pass "") + (qpass "") + (cmd "") + (result (unwind-protect + (progn + (condition-case nil + (setq pass (efs-get-passwd host user)) + (quit (condition-case nil + (kill-buffer (process-buffer proc)) + (error nil)) + (signal 'quit nil))) + (setq cmd (concat + "quote pass " + (setq qpass (efs-quote-string nil pass t)))) + (efs-raw-send-cmd proc cmd)) + (fillarray pass 0) + (fillarray qpass 0) + (fillarray cmd 0))) + (code (and (>= (length (nth 1 result)) 4) + (substring (nth 1 result) 0 4)))) + (or code (setq code "")) + ;; Analyze the result. + (cond + ((string-equal code "332 ") + ;; require an account passwd + (setq result (efs-login-send-acct host user proc gate))) + ((null (car result)) + ;; logged in proceed + nil) + ((or (string-equal code "530 ") (string-equal code "421 ")) + ;; Give the user another chance + (condition-case nil + (if (efs-anonymous-p user) + (if (or (string-match efs-too-many-users-msgs (nth 1 result)) + (string-match efs-too-many-users-msgs (nth 2 result))) + (if (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (y-or-n-p (format + "Too many users for %s@%s. Try again? " + user host))) + (progn + ;; Return nil if we are doing a retry, so done + ;; message only gets sent once. + (setq result nil) + (if (string-equal code "530 ") + (efs-login-send-user host user proc gate) + (efs-get-process host user))) + (signal 'quit nil)) + (unwind-protect + (efs-set-passwd + host user + (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (setq pass + (read-passwd + (format + "Password for %s@%s failed. Try again: " + user host))))) + (fillarray pass 0)) + (setq result nil) + (efs-login-send-user host user proc gate)) + (unwind-protect + (efs-set-passwd + host user + (setq pass + (read-passwd + (format "Password for %s@%s failed. Try again: " + user host)))) + (fillarray pass 0)) + (setq result nil) + (efs-login-send-user host user proc gate)) + (quit (condition-case nil (delete-process proc) (error nil)) + (efs-set-user host nil) + (efs-set-passwd host user nil) + (signal 'quit nil)) + (error (condition-case nil (delete-process proc) (error nil)) + (efs-set-user host nil) + (efs-set-passwd host user nil) + (efs-error host user "PASS request failed.")))) + (t ; bombed for unexplained reasons + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "PASS request failed: " (nth 1 result))))) + result)) + +(defun efs-login-send-acct (host user proc &optional gate) + "Sends account password to HOST and USER. PROC is the ftp client process. +Doesn't call efs-save-match data. You must do that yourself." + (let* ((acct "") + (qacct "") + (cmd "") + (result (unwind-protect + (progn + ;; The raptor gateway requires us to send a gateway + ;; authentication password for account. What if the + ;; remote server wants one too? + (setq acct (if (eq gate 'raptor) + (efs-get-account + efs-gateway-host + (nth 3 efs-gateway-type) nil t) + (efs-get-account host user nil t)) + qacct (efs-quote-string nil acct t) + cmd (concat "quote acct " qacct)) + (efs-raw-send-cmd proc cmd)) + (fillarray acct 0) + (fillarray qacct 0) + (fillarray cmd 0)))) + ;; Analyze the result + (cond + ((null (car result)) + ;; logged in proceed + nil) + ((eq (car result) 'failed) + ;; Give the user another chance + (condition-case nil + (progn + (unwind-protect + (progn + (setq acct (read-passwd + (format + "Account password for %s@%s failed. Try again: " + user host))) + (or (and efs-high-security-hosts + (string-match efs-high-security-hosts + (format "%s@%s" user host))) + (efs-set-account host user nil acct))) + (fillarray acct 0)) + (setq result (efs-login-send-user host user proc gate))) + (quit (condition-case nil (delete-process proc) (error nil))) + (error (condition-case nil (delete-process proc) (error nil)) + (efs-error host user "ACCT request failed.")))) + (t ; bombed for unexplained reasons + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "ACCT request failed: " (nth 1 result))))) + result)) + +;;;; ---------------------------------------------------------------------- +;;;; Changing working directory. +;;;; ---------------------------------------------------------------------- + +(defun efs-raw-send-cd (host user dir &optional no-error) + ;; If NO-ERROR, doesn't barf, but just returns success (t) or failure (nil). + ;; This does not use efs-send-cmd. + ;; Also DIR must be in the syntax of the remote host-type. + (let* ((cmd (concat "cd " dir)) + cd-result cd-line) + (efs-raw-send-cmd + (efs-get-process host user) + cmd nil nil + (efs-cont (result line cont-lines) (cmd) + (if (eq result 'fatal) + (efs-raw-send-cmd + (efs-get-process host user) + cmd nil nil + (function (lambda (result line cont-lines) + (setq cd-result result + cd-line line)))) + (setq cd-result result + cd-line line)))) + (if no-error + (null cd-result) + (if cd-result + (efs-error host user (concat "CD failed: " cd-line)))))) + +;;;; -------------------------------------------------------------- +;;;; Getting a PWD. +;;;; -------------------------------------------------------------- + +(defun efs-unquote-quotes (string) + ;; Unquote \"\"'s in STRING to \". + (let ((start 0) + new) + (while (string-match "\"\"" string start) + (setq new (concat new (substring + string start (1+ (match-beginning 0)))) + start (match-end 0))) + (if new + (concat new (substring string start)) + string))) + +(efs-defun efs-send-pwd nil (host user &optional xpwd) + "Attempts to get the current working directory for the given HOST/USER pair. +Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, +and LINE is the relevant success or fail line from the FTP-server. If the +optional arg XPWD is given, uses this server command instead of PWD." + (let* ((result (efs-send-cmd host user + (list 'quote (if xpwd 'xpwd 'pwd)) + "Getting pwd")) + (line (nth 1 result)) + dir) + (or (car result) + (efs-save-match-data + (if (string-match "\"\\(.*\\)\"[^\"]*$" line) + (setq dir (efs-unquote-quotes (substring line (match-beginning 1) + (match-end 1)))) + (if (string-match " \\([^ ]+\\) " line) ; stone-age servers! + (setq dir (substring line + (match-beginning 1) + (match-end 1))))))) + (cons dir line))) + +(efs-defun efs-send-pwd super-dumb-unix (host user &optional xpwd) + ;; Guess at the pwd for a unix host that doesn't support pwd. + (if (efs-anonymous-p user) + ;; guess + (cons "/" "") + ;; Who knows? + (message "Can't obtain pwd for %s" host) + (ding) + (sleep-for 2) + (message "All file names must be specified as full paths.") + (cons nil ""))) + +;;;; -------------------------------------------------------- +;;;; Getting the SIZE of a remote file. +;;;; -------------------------------------------------------- + +(defun efs-send-size (host user file) + "For HOST and USER, get the size of FILE in bytes. +This returns a list \( SIZE . LINE \), where SIZE is the file size in bytes, +or nil if this couldn't be determined, and LINE is the output line of the +FTP server." + (efs-save-match-data + (let ((result (efs-send-cmd host user (list 'quote 'size file)))) + (setcar result + (and (null (car result)) + (string-match "^213 +\\([0-9]+\\)$" (nth 1 result)) + (string-to-int + (substring + (cdr result) + (match-beginning 1) (match-end 1))))) + result))) + +;;;; ------------------------------------------------------------ +;;;; umask support +;;;; ------------------------------------------------------------ + +(defun efs-umask (user) + "Returns the umask that efs will use for USER. +If USER is root or anonymous, then the values of efs-root-umask +and efs-anonymous-umask, respectively, take precedence, to be followed +by the value of efs-umask, and if this is nil, it returns your current +umask on the local machine. Returns nil if this can't be determined." + (or + (and (string-equal user "root") efs-root-umask) + (and (efs-anonymous-p user) + efs-anonymous-umask) + efs-umask + (let* ((shell (or (and (boundp 'explicit-shell-file-name) + explicit-shell-file-name) + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh")) + (default-major-mode 'fundamental-mode) + (default-directory exec-directory) + (buff (get-buffer-create " *efs-umask-data*"))) + (unwind-protect + (save-excursion + (set-buffer buff) + (call-process shell nil buff nil "-c" "umask") + (goto-char (point-min)) + (if (re-search-forward "[0-7]?[0-7]?[0-7]" nil t) + (string-to-int (buffer-substring (match-beginning 0) + (match-end 0))))) + (kill-buffer buff))))) + +(defun efs-send-umask (host user mask) + "Sets the umask on HOST for USER to MASK. +Returns t for success, nil for failure." + (interactive + (let* ((path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (parsed (and path (efs-ftp-path path))) + (default-host (car parsed)) + (default-user (nth 1 parsed)) + (default-mask (efs-umask default-user))) + (list + (read-string "Host: " default-host) + (read-string "User: " default-user) + (read-string "Umask: " (int-to-string default-mask))))) + (let (int-mask) + (if (integerp mask) + (setq int-mask mask + mask (int-to-string mask)) + (setq int-mask (string-to-int mask))) + (or (string-match "^ *[0-7]?[0-7]?[0-7] *$" mask) + (error "Invalid umask %s" mask)) + (efs-send-cmd host user + (list 'quote 'site 'umask mask) + (concat "Setting umask to " mask) + (list + (function + (lambda (int-mask) + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-umask int-mask)))))) + int-mask) + (efs-cont (result line cont-lines) (host user mask) + (if result + (let ((buff (efs-ftp-process-buffer host user))) + (efs-set-host-property host 'umask-failed t) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-umask nil))) + (message + "Unable to set umask to %s on %s" mask host) + (if efs-ding-on-umask-failure + (progn + (ding) + (sit-for 1)))))) + 0))) ; Do this NOWAIT = 0 + +(defun efs-set-umask (host user) + "Sets the umask for HOST and USER, if it has not already been set." + (save-excursion + (set-buffer (process-buffer (efs-get-process host user))) + (if (or efs-process-umask (efs-get-host-property host 'umask-failed)) + nil + (let ((umask (efs-umask user))) + (efs-send-umask host user umask) + t)))) ; Tell the caller that we did something. + +(defun efs-modes-from-umask (umask) + ;; Given the 3 digit octal integer umask, returns the decimal integer + ;; according to chmod that a file would be written with. + ;; Assumes only ordinary files, so ignores x bits. + (let* ((others (% umask 10)) + (umask (/ umask 10)) + (group (% umask 10)) + (umask (/ umask 10)) + (owner (% umask 10)) + (factor 1)) + (apply '+ + (mapcar + (function + (lambda (x) + (prog1 + (* factor (- 6 (- x (% x 2)))) + (setq factor (* factor 8))))) + (list others group owner))))) + +;;;; ------------------------------------------------------------ +;;;; Idle time manipulation. +;;;; ------------------------------------------------------------ + +(defun efs-check-idle (host user) + ;; We just toss it in the queue to run whenever there's time. + ;; Just fail quietly if this doesn't work. + (if (and (or efs-maximize-idle efs-expire-ftp-buffers) + (memq (efs-host-type host) efs-idle-host-types) + (null (efs-get-host-property host 'idle-failed))) + (let ((buffname (efs-ftp-process-buffer host user))) + (efs-add-to-queue + host user + (list '(quote site idle) + nil nil + (efs-cont (result line cont-lines) (host user buffname) + (efs-save-match-data + (if (and (null result) + (string-match efs-idle-msgs line)) + (let ((max (substring line (match-beginning 2) + (match-end 2)))) + (if (get-buffer buffname) + (save-excursion + (set-buffer buffname) + (setq efs-process-idle-time + (string-to-int + (substring line (match-beginning 1) + (match-end 1)))))) + (if (and efs-maximize-idle + (not (efs-anonymous-p user))) + (efs-add-to-queue + host user + (list + (list 'quote 'site 'idle max) + nil nil + (efs-cont (result line cont-lines) (buffname + max) + (and (null result) + (get-buffer buffname) + (save-excursion + (set-buffer buffname) + (setq efs-process-idle-time + (string-to-int max))))) + 0)))) + (efs-set-host-property host 'idle-failed t)))) + 0 nil))))) ; Using NOWAIT = 0 inhibits mode line toggling. + + +;;;; ------------------------------------------------------------ +;;;; Sending the SYST command for system type. +;;;; ------------------------------------------------------------ + +(defun efs-get-syst (host user) + "Use SYST to get the remote system type. +Returns the system type as a string if this succeeds, otherwise nil." + (let* ((result (efs-send-cmd host user '(quote syst))) + (line (nth 1 result))) + (efs-save-match-data + (and (null (car result)) + (string-match efs-syst-msgs line) + (substring line (match-end 0)))))) + +;;;; ------------------------------------------------------------ +;;;; File transfer representation type support +;;;; ------------------------------------------------------------ + +;;; Legal representation types are: image, ascii, ebcdic, tenex + +(efs-defun efs-file-type nil (path) + ;; Returns the file type for PATH, the full efs path, with filename FILE. + ;; The return value is one of 'text, '8-binary, or '36-binary. + (let ((parsed (efs-ftp-path path))) + (efs-save-match-data + (cond + ;; There is no special significance to temp names, but we assume that + ;; they exist on an 8-bit byte machine. + ((or (null path) + (let ((temp (intern-soft path efs-tmp-name-obarray))) + (and temp (memq temp efs-tmp-name-files)))) + '8-binary) + ((and (null parsed) (file-exists-p path)) + (efs-local-file-type path)) + ;; test special hosts + ((and parsed + efs-binary-file-host-regexp + (let ((case-fold-search t)) + (string-match efs-binary-file-host-regexp (car parsed)))) + '8-binary) + (t + ;; Test file names + (let ((file (efs-internal-file-name-nondirectory + (or (nth 2 parsed) path)))) + (cond + ;; test for PDP-10 binaries + ((and efs-36-bit-binary-file-name-regexp + (string-match efs-36-bit-binary-file-name-regexp file)) + '36-binary) + ((and efs-binary-file-name-regexp + (string-match efs-binary-file-name-regexp file)) + '8-binary) + ((and efs-text-file-name-regexp + (string-match efs-text-file-name-regexp file)) + 'text) + ;; by default + (t + '8-binary)))))))) + +(efs-define-fun efs-local-file-type (file) + ;; Looks at the beginning (magic-cookie) of a local file to determine + ;; if it is a text file or not. If it's not a text file, it doesn't care + ;; about what type of binary file, so this doesn't really look for a magic + ;; cookie. + ;; Doesn't call efs-save-match-data. The caller should do so. + (save-excursion + (set-buffer (get-buffer-create efs-data-buffer-name)) + (erase-buffer) + (insert-file-contents file nil 0 16) + (if (looking-at "[ -~\n\r\C-L]*\\'") + 'text + '8-binary))) + +(defun efs-rationalize-file-type (f-type t-type) + ;; When the original and new names for a file indicate + ;; different file types, this function applies an ad hoc heuristic + ;; to return a single file type. + (cond + ((eq f-type t-type) + f-type) + ((memq '36-binary (list f-type t-type)) + '36-binary) + ((memq '8-binary (list f-type t-type)) + '8-binary) + (t + 'text))) + +(defun efs-prompt-for-transfer-type (arg) + "Toggles value of efs-prompt-for-transfer-type. +With prefix arg, turns prompting on if arg is positive, otherwise turns +prompting off." + (interactive "P") + (if (if arg + (> (prefix-numeric-value arg) 0) + (null efs-prompt-for-transfer-type)) + ;; turn prompting on + (prog1 + (setq efs-prompt-for-transfer-type t) + (message "Prompting for FTP transfer TYPE is on.")) + (prog1 + (setq efs-prompt-for-transfer-type nil) + (message "Prompting for FTP transfer TYPE is off.")))) + +(defun efs-read-xfer-type (path) + ;; Prompt for the transfer type to use for PATH + (let ((type + (completing-read + (format "FTP transfer TYPE for %s: " (efs-relativize-filename path)) + '(("binary") ("image") ("ascii") ("ebcdic") ("tenex")) + nil t))) + (if (string-equal type "binary") + 'image + (intern type)))) + +(defun efs-xfer-type (f-host-type f-path t-host-type t-path + &optional via-local) + ;; Returns the transfer type for transferring a file. + ;; F-HOST-TYPE = the host type of the machine on which the file is from. + ;; F-PATH = path, in full efs-syntax, of the original file + ;; T-HOST-TYPE = host-type of the machine to which the file is being + ;; transferred. + ;; VIA-LOCAL = non-nil of the file is being moved through the local, or + ;; a gateway machine. + ;; Set F-PATH or T-PATH to nil, to indicate that the file is being + ;; transferred from/to a temporary file, whose name has no significance. + (let (temp) + (and f-path + (setq temp (intern-soft f-path efs-tmp-name-obarray)) + (memq temp efs-tmp-name-files) + (setq f-path nil)) + (and t-path + (setq temp (intern-soft t-path efs-tmp-name-obarray)) + (memq temp efs-tmp-name-files) + (setq t-path nil))) + (if (or (null (or f-host-type t-host-type)) (null (or f-path t-path))) + 'image ; local copy? + (if efs-prompt-for-transfer-type + (efs-read-xfer-type (if f-path f-path t-path)) + (let ((f-fs (cdr (assq f-host-type efs-file-type-alist))) + (t-fs (cdr (assq t-host-type efs-file-type-alist)))) + (if (and f-fs t-fs + (if efs-treat-crlf-as-nl + (and (eq (car f-fs) (car t-fs)) + (eq (nth 1 f-fs) (nth 1 t-fs)) + (let ((f2-fs (nth 2 f-fs)) + (t2-fs (nth 2 t-fs))) + (or (eq f2-fs t2-fs) + (and (memq f2-fs '(file-crlf file-nl)) + (memq t2-fs '(file-crlf file-nl)))))) + (equal f-fs t-fs))) + 'image + (let ((type (cond + ((and f-path t-path) + (efs-rationalize-file-type + (efs-file-type t-host-type t-path) + (efs-file-type f-host-type f-path))) + (f-path + (efs-file-type f-host-type f-path)) + (t-path + (efs-file-type t-host-type t-path))))) + (cond + ((eq type '36-binary) + 'image) + ((eq type '8-binary) + (if (or (eq (car f-fs) '36-bit-wa) + (eq (car t-fs) '36-bit-wa)) + 'tenex + 'image)) + (t ; handles 'text + (if (and t-fs f-fs (eq (nth 1 f-fs) 'ebcdic) + (eq (nth 1 t-fs) 'ebcdic) (null via-local)) + 'ebcdic + 'ascii))))))))) + +(defun efs-set-xfer-type (host user type &optional clientless) + ;; Sets the xfer type for HOST and USER to TYPE. + ;; If the connection is already using the required type, does nothing. + ;; If clientless is non-nil, we are using a quoted xfer command, and + ;; need to check if the client has changed things. + (save-excursion + (let ((buff (process-buffer (efs-get-process host user)))) + (set-buffer buff) + (or (if (and clientless efs-process-client-altered-xfer-type) + (or (eq type efs-process-client-altered-xfer-type) + (setq efs-process-client-altered-xfer-type nil)) + ;; We are sending a non-clientless command, so the client + ;; gets back in synch. + (setq efs-process-client-altered-xfer-type nil) + (and efs-process-xfer-type + (eq type efs-process-xfer-type))) + (let ((otype efs-process-xfer-type)) + ;; Set this now in anticipation that the TYPE command will work, + ;; in case other commands, such as efs-set-hash-mark-unit want to + ;; grok this before the TYPE command completes. + (setq efs-process-xfer-type type) + (efs-send-cmd + host user (list 'type type) + nil nil + (efs-cont (result line cont-lines) (host user type otype buff) + (if result + (unwind-protect + (efs-error host user (format "TYPE %s failed: %s" + (upcase (symbol-name type)) + line)) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-xfer-type otype)))))) + 0)))))) ; always send type commands NOWAIT = 0 + + +;;;; ------------------------------------------------------------ +;;;; Obtaining DIR listings. +;;;; ------------------------------------------------------------ + +(defun efs-ls-guess-switches () + ;; Tries to determine what would be the most useful switches + ;; to use for a DIR listing. + (if (and (boundp 'dired-listing-switches) + (stringp dired-listing-switches) + (efs-parsable-switches-p dired-listing-switches t)) + dired-listing-switches + "-al")) + +(efs-defun efs-ls-dumb-check nil (line host file path lsargs msg noparse + noerror nowait cont) + nil) + +(efs-defun efs-ls-dumb-check unknown (line host file path lsargs + msg noparse noerror nowait cont) + ;; Checks to see if the host type might be dumb unix. If so, returns the + ;; listing otherwise nil. + (and + lsargs + (string-match + ;; Some CMU servers return a 530 here. 550 is correct. + (concat "^5[35]0 \\(The file \\)?" + (regexp-quote (concat lsargs " " path))) + ;; 550 is for a non-accessible file -- RFC959 + line) + (progn + (if (eq (efs-host-type host) 'apollo-unix) + (efs-add-host 'dumb-apollo-unix host) + (efs-add-host 'dumb-unix host)) + ;; try again + (if nowait + t ; return t if asynch + ; This is because dumb-check can't run asynch. + ; This means that we can't recognize dumb hosts asynch. + ; Shouldn't be a problem. + (efs-ls file nil + (if (eq msg t) + (format "Relisting %s" (efs-relativize-filename file)) + msg) + noparse noerror nowait cont))))) + +;; With no-error nil, this function returns: +;; an error if file is not an efs-path +;; (This should never happen.) +;; an error if either the listing is unreadable or there is an ftp error. +;; the listing (a string), if everything works. +;; +;; With no-error t, it returns: +;; an error if not an efs-path +;; error if listing is unreable (most likely caused by a slow connection) +;; nil if ftp error (this is because although asking to list a nonexistent +;; directory on a remote unix machine usually (except +;; maybe for dumb hosts) returns an ls error, but no +;; ftp error, if the same is done on a VMS machine, +;; an ftp error is returned. Need to trap the error +;; so we can go on and try to list the parent.) +;; the listing, if everything works. + +(defun efs-ls (file lsargs msg &optional noparse noerror nowait cont nlist) + "Return the output of a `DIR' or `ls' command done over ftp. +FILE is the full name of the remote file, LSARGS is any args to pass to the +`ls' command. MSG is a message to be displayed while listing, if MSG is given +as t, a suitable message will be computed. If nil, no message will be +displayed. If NOPARSE is non-nil, then the listing will not be parsed and +stored in internal cache. Otherwise, the listing will be parsed, if LSARGS +allow it. If NOERROR is non-nil, then we return nil if the listing fails, +rather than signal an error. If NOWAIT is non-nil, we do the listing +asynchronously, returning nil. If CONT is non-nil it is called with first +argument the listing string." + ;; If lsargs are nil, this forces a one-time only dumb listing using dir. + (setq file (efs-expand-file-name file)) + (let ((parsed (efs-ftp-path file))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (host-type (efs-host-type host user)) + (listing-type (efs-listing-type host user)) + (parse (cond + ((null noparse) + (efs-parsable-switches-p lsargs t)) + ((eq noparse 'parse) + t) + (t nil))) + (switches lsargs) + cache) + + (if (memq host-type efs-dumb-host-types) + (setq lsargs nil)) + (if (and (null efs-ls-uncache) + (setq cache + (or (efs-get-from-ls-cache file switches) + (and switches + (efs-convert-from-ls-cache + file switches host-type listing-type))))) + ;; The listing is in the mail, errr... cache. + (let (listing) + (if (stringp cache) + (setq listing cache) + (setq listing (car cache)) + (if (and parse (null (nth 1 cache))) + (save-excursion + (set-buffer + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create + efs-data-buffer-name))) + (erase-buffer) + (insert listing) + (goto-char (point-min)) + (efs-set-files + file + (efs-parse-listing listing-type + host user path + file lsargs)) + ;; Note that we have parsed it now. + (setcar (cdr cache) t)))) + (if cont (efs-call-cont cont listing)) + listing) + + (if cache + (efs-del-from-ls-cache file nil nil)) + ;; Need to get the listing via FTP. + (let* ((temp (efs-make-tmp-name host nil)) + (temp-file (car temp)) + listing-result) + (efs-send-cmd + host user + (list (if nlist 'nlist 'dir) path (cdr temp) lsargs) + (if (eq msg t) + (format "Listing %s" (efs-relativize-filename file)) + msg) + nil + (efs-cont (result line cont-lines) + (host-type listing-type host user temp-file path + switches file lsargs noparse parse noerror + msg nowait cont) + ;; The client flipped to ascii, remember this. + (let ((buff (get-buffer + (efs-ftp-process-buffer host user)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (setq efs-process-client-altered-xfer-type + 'ascii)))) + (unwind-protect + (if result + (or (setq listing-result + (efs-ls-dumb-check + (and (or (eq host-type 'unknown) + (eq listing-type 'unix:unknown)) + 'unknown) + line host file path lsargs msg + noparse noerror nowait cont)) + ;; If dumb-check returns non-nil + ;; then it would have handled any error recovery + ;; and conts. listing-result would only be set to + ;; t if nowait was non-nil. Therefore, the final + ;; return for efs-ls could never be t, even if I + ;; set listing-result to t here. + (if noerror + (if cont + (efs-call-cont cont nil)) + (efs-error host user + (concat "DIR failed: " + line)))) + + ;; listing worked + (if (efs-ftp-path temp-file) + (efs-add-file-entry (efs-host-type efs-gateway-host) + temp-file nil nil nil)) + (save-excursion + ;; A hack to get around a jka-compr problem. + ;; Do we still need it? + (let ((default-major-mode 'fundamental-mode) + efs-verbose jka-compr-enabled) + (set-buffer (get-buffer-create + efs-data-buffer-name)) + (erase-buffer) + (if (or (file-readable-p temp-file) + (sleep-for efs-retry-time) + (file-readable-p temp-file)) + (insert-file-contents temp-file) + (efs-error host user + (format + "list data file %s not readable" + temp-file)))) + (if parse + (progn + (efs-set-files + file + (efs-parse-listing listing-type host user path + file lsargs)) + ;; Parsing may update the host type. + (and lsargs (memq (efs-host-type host) + efs-dumb-host-types) + (setq lsargs nil)))) + (let ((listing (buffer-string))) + (efs-add-to-ls-cache file lsargs listing parse) + (if (and (null lsargs) switches) + ;; Try to convert + (let ((conv (efs-get-ls-converter switches))) + (and conv + (setq conv (assoc + (char-to-string 0) + conv)) + (funcall (cdr conv) listing-type nil) + (setq listing (buffer-string))))) + (or nowait (setq listing-result listing)) + ;; Call the ls cont, with first arg the + ;; listing string. + (if cont + (efs-call-cont cont listing))))) + (efs-del-tmp-name temp-file))) + nowait) + (and (null nowait) listing-result)))) + (error "Attempt to get a remote listing for the local file %s" file)))) + + +;;;; =============================================================== +;;;; >7 +;;;; Parsing and storing remote file system data. +;;;; =============================================================== + +;;; The directory listing parsers do some host type guessing. +;;; Most of the host type guessing is done when the PWD output +;;; is parsed. A bit is done when the error codes for DIR are +;;; analyzed. + +;;;; ----------------------------------------------------------- +;;;; Caching directory listings. +;;;; ----------------------------------------------------------- + +;;; Aside from storing files data in a hashtable, a limited number +;;; of listings are stored in complete form in `efs-ls-cache'. + +(defun efs-del-from-ls-cache (file &optional parent-p dir-p) + ;; Deletes from the ls cache the listing for FILE. + ;; With optional PARENT-P, deletes any entry for the parent + ;; directory of FILE too. + ;; If DIR-P is non-nil, then the directory listing of FILE is to be deleted. + (if dir-p + (setq file (file-name-as-directory file)) + (setq file (directory-file-name file))) + (setq file (efs-canonize-file-name file)) + (if parent-p + (setq parent-p (file-name-directory + (if dir-p + (directory-file-name file) + file)))) + (setq efs-ls-cache + (delq nil + (mapcar + (if parent-p + (function + (lambda (x) + (let ((f-ent (car x))) + (and (not (string-equal file f-ent)) + (not (string-equal parent-p f-ent)) + x)))) + (function + (lambda (x) + (and (not (string-equal file (car x))) + x)))) + efs-ls-cache)))) + +(defun efs-wipe-from-ls-cache (host user) + ;; Remove from efs-ls-cache all listings for HOST and USER. + (let ((host (downcase host)) + (case-insens (memq (efs-host-type host) + efs-case-insensitive-host-types))) + (if case-insens (setq user (downcase user))) + (setq efs-ls-cache + (delq nil + (mapcar + (function + (lambda (x) + (let ((parsed (efs-ftp-path (car x)))) + (and (not + (and (string-equal (car parsed) host) + (string-equal (if case-insens + (downcase (nth 1 parsed)) + (nth 1 parsed)) + user))) + x)))) + efs-ls-cache))))) + +(defun efs-get-from-ls-cache (file switches) + ;; Returns the value in `ls-cache' for FILE and SWITCHES. + ;; Returns a list consisting of the listing string, and whether its + ;; already been parsed. This list is eq to the nthcdr 2 of the actual + ;; cache entry, so you can setcar it. + ;; For dumb listings, SWITCHES will be nil. + (let ((list efs-ls-cache) + (switches (efs-canonize-switches switches)) + (file (efs-canonize-file-name file))) + (catch 'done + (while list + (if (and (string-equal file (car (car list))) + (string-equal switches (nth 1 (car list)))) + (throw 'done (nthcdr 2 (car list))) + (setq list (cdr list))))))) + +(defun efs-add-to-ls-cache (file switches listing parsed) + ;; Only call after efs-get-from-cache returns nil, to avoid duplicate + ;; entries. PARSED should be t, if the listing has already been parsed. + (and (> efs-ls-cache-max 0) + (let ((switches (efs-canonize-switches switches)) + (file (efs-canonize-file-name file))) + (if (= efs-ls-cache-max 1) + (setq efs-ls-cache + (list (list file switches listing parsed))) + (if (>= (length efs-ls-cache) efs-ls-cache-max) + (setcdr (nthcdr (- efs-ls-cache-max 2) efs-ls-cache) nil)) + (setq efs-ls-cache (cons (list file switches listing parsed) + efs-ls-cache)))))) + +;;;; -------------------------------------------------------------- +;;;; Converting listings from cache. +;;;; -------------------------------------------------------------- + +(defun efs-get-ls-converter (to-switches) + ;; Returns converter alist for TO-SWITCHES + (efs-get-hash-entry (efs-canonize-switches to-switches) + efs-ls-converter-hashtable)) + +(defun efs-add-ls-converter (to-switches from-switches converter) + ;; Adds an entry to `efs-ls-converter-hashtable'. + ;; If from-switches is t, the converter converts from internal files + ;; hashtable. + (let* ((to-switches (efs-canonize-switches to-switches)) + (ent (efs-get-hash-entry to-switches efs-ls-converter-hashtable)) + (add (cons (or (eq from-switches t) + (efs-canonize-switches from-switches)) + converter))) + (if ent + (or (member add ent) + (nconc ent (list add))) + (efs-put-hash-entry to-switches (list add) efs-ls-converter-hashtable)))) + +(defun efs-convert-from-ls-cache (file switches host-type listing-type) + ;; Returns a listing by converting the switches from a cached listing. + (let ((clist (efs-get-ls-converter switches)) + (dir-p (= ?/ (aref file (1- (length file))))) + elt listing result regexp alist) + (while file ; this loop will iterate at most twice. + (setq alist clist) + (while alist + (setq elt (car alist)) + (if (eq (car elt) t) + (if (and dir-p (setq result (funcall (cdr elt) host-type + (let ((efs-ls-uncache t)) + (efs-get-files file)) + regexp))) + (setq alist nil + file nil) + (setq alist (cdr alist))) + (if (and (setq listing + (efs-get-from-ls-cache file (car elt))) + (save-excursion + (set-buffer + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create efs-data-buffer-name))) + (erase-buffer) + (insert (car listing)) + (and (funcall (cdr elt) listing-type regexp) + (setq result (buffer-string))))) + (setq alist nil + file nil) + (setq alist (cdr alist))))) + ;; Look for wildcards. + (if (and file (null dir-p) (null regexp)) + (setq regexp (efs-shell-regexp-to-regexp + (file-name-nondirectory file)) + file (file-name-directory file) + dir-p t) + (setq file nil))) + result)) + +;;; Define some converters + +(defun efs-unix-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minutes1 (nth 4 data1)) + (minutes2 (nth 4 data2))) + (if year1 + (and year2 + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (> day1 day2)))))) + (if year2 + t + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (> minutes1 minutes2))))))))))) + +(defun efs-unix-t-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let ((current-month (cdr (assoc (substring + (current-time-string) 4 7) + efs-month-alist))) + list-start start end list year month day hour minutes) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (forward-line 1) + (setq end (point)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp end t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq month (% (+ (- 11 current-month) + (cdr (assoc + (buffer-substring (match-beginning 2) + (match-end 2)) + efs-month-alist))) 12) + day (string-to-int + (buffer-substring (match-beginning 3) (match-end 3))) + year (buffer-substring (match-beginning 4) (match-end 4))) + (if (string-match ":" year) + (setq hour (string-to-int (substring year 0 + (match-beginning 0))) + minutes (string-to-int (substring year (match-end 0))) + year nil) + (setq hour nil + minutes nil + year (string-to-int year))) + (setq list (cons + (cons + (list year month day hour minutes) + (buffer-substring start end)) + list)) + (goto-char end)) + (setq list + (mapcar 'cdr + (sort list 'efs-unix-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list) + t))))) + +(efs-defun efs-t-converter nil (&optional regexp reverse) + ;; Converts listing without the t-switch, to ones with it. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-t-converter 'unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'sysV-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'apollo-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'bsd-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'dumb-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'dumb-apollo-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'super-dumb-unix 'efs-unix-t-converter) + +(defun efs-rt-converter (listing-type &optional regexp) + ;; Reverse time sorting + (efs-t-converter listing-type regexp t)) + +(defun efs-unix-alpha-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (list list-start end start next) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (end-of-line) + (setq end (point) + next (1+ end)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp end t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq list + (cons + (cons (buffer-substring (point) end) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + t))))) + +(efs-defun efs-alpha-converter nil (&optional regexp reverse) + ;; Converts listing to lexigraphical order. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-alpha-converter 'unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'sysV-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'apollo-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'bsd-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'dumb-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'dumb-apollo-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'super-dumb-unix 'efs-unix-alpha-converter) + +(defun efs-ralpha-converter (listing-type &optional regexp) + ;; Reverse alphabetic + (efs-alpha-converter listing-type regexp t)) + +(defun efs-unix-S-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (list list-start start next) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (forward-line 1) + (setq next (point)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp next t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq list + (cons + (cons (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (< (car x) (car y)))) + (function + (lambda (x y) + (> (car x) (car y)))))))) + t))))) + +(efs-defun efs-S-converter nil (&optional regexp reverse) + ;; Converts listing without the S-switch, to ones with it. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-S-converter 'unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'sysV-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'apollo-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'bsd-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'dumb-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'dumb-apollo-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'super-dumb-unix 'efs-unix-S-converter) + +(defun efs-rS-converter (listing-type &optional regexp) + ;; Reverse S switch. + (efs-S-converter listing-type regexp t)) + +(defun efs-unix-X-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (next list list-start fnstart eol start end link-p) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (skip-chars-forward "0-9 ") + (setq link-p (= (following-char) ?l)) + (end-of-line) + (setq eol (point) + next (1+ eol)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp eol t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq fnstart (point)) + (or (and link-p (search-forward " -> " eol t) + (goto-char (match-beginning 0))) + (goto-char eol)) + (setq end (point)) + (skip-chars-backward "^." fnstart) + (setq list + (cons + (cons + (if (= (point) fnstart) + "" + (buffer-substring (point) end)) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + t))))) + +(efs-defun efs-X-converter nil (&optional regexp reverse) + ;; Sort on file name extension. By default do nothing + nil) + +(defun efs-rX-converter (listing-type &optional regexp) + (efs-X-converter listing-type regexp t)) + +(efs-fset 'efs-X-converter 'unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'sysV-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'apollo-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'bsd-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'dumb-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'dumb-apollo-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'super-dumb-unix 'efs-unix-X-converter) + +;;; Brief listings + +;;; The following functions do a heap better at packing than +;;; the usual ls listing. A variable column width is used. +(defun efs-column-widths (columns list &optional across) + ;; Returns the column widths for breaking LIST into + ;; COLUMNS number of columns. + (cond + ((null list) + nil) + ((= columns 1) + (list (apply 'max (mapcar 'length list)))) + ((let* ((len (length list)) + (col-length (/ len columns)) + (remainder (% len columns)) + (i 0) + (j 0) + (max-width 0) + widths padding) + (if (zerop remainder) + (setq padding 0) + (setq col-length (1+ col-length) + padding (- columns remainder))) + (setq list (nconc (copy-sequence list) (make-list padding nil))) + (setcdr (nthcdr (1- (+ len padding)) list) list) + (while (< i columns) + (while (< j col-length) + (setq max-width (max max-width (length (car list))) + list (if across (nthcdr columns list) (cdr list)) + j (1+ j))) + (setq widths (cons (+ max-width 2) widths) + max-width 0 + j 0 + i (1+ i)) + (if across (setq list (cdr list)))) + (setcar widths (- (car widths) 2)) + (nreverse widths))))) + +(defun efs-calculate-columns (list &optional across) + ;; Returns a list of integers which are the column widths that best pack + ;; LIST, a list of strings, onto the screen. + (and list + (let* ((width (1- (window-width))) + (columns (max 1 (/ width + (+ 2 (apply 'max (mapcar 'length list)))))) + col-list last-col-list) + (while (<= (apply '+ (setq col-list + (efs-column-widths columns list across))) + width) + (setq columns (1+ columns) + last-col-list col-list)) + (or last-col-list col-list)))) + +(defun efs-format-columns-of-files (files &optional across) + ;; Returns the number of lines used. + ;; If ACROSS is non-nil, sorts across rather than down the buffer, like + ;; ls -x + ;; A beefed up version of the function in dired. Thanks Sebastian. + (and files + (let* ((columns (efs-calculate-columns files across)) + (ncols (length columns)) + (ncols1 (1- ncols)) + (nfiles (length files)) + (nrows (+ (/ nfiles ncols) + (if (zerop (% nfiles ncols)) 0 1))) + (space-left (- (window-width) (apply '+ columns) 1)) + (stretch (/ space-left ncols1)) + (float-stretch (if (zerop ncols1) 0 (% space-left ncols1))) + (i 0) + (j 0) + (result "") + file padding) + (setq files (nconc (copy-sequence files) ; fill up with empty fns + (make-list (- (* ncols nrows) nfiles) ""))) + (setcdr (nthcdr (1- (length files)) files) files) ; make circular + (while (< j nrows) + (while (< i ncols) + (setq result (concat result (setq file (car files)))) + (setq padding (- (nth i columns) (length file))) + (or (= i ncols1) + (progn + (setq padding (+ padding stretch)) + (if (< i float-stretch) (setq padding (1+ padding))))) + (setq result (concat result (make-string padding ?\ ))) + (setq files (if across (cdr files) (nthcdr nrows files)) + i (1+ i))) + (setq result (concat result "\n")) + (setq i 0 + j (1+ j)) + (or across (setq files (cdr files)))) + result))) + +(defun efs-brief-converter (host-type file-table F a A p x C &optional regexp) + ;; Builds a brief directory listing for file cache, with + ;; possible switches F, a, A, p, x. + (efs-save-match-data + (let (list ent modes) + (efs-map-hashtable + (function + (lambda (key val) + (if (and + (efs-really-file-p host-type key val) + (or a + (and A (not (or (string-equal "." key) + (string-equal ".." key)))) + (/= (string-to-char key) ?.)) + (or (null regexp) + (string-match regexp key))) + (setq ent (car val) + modes (nth 3 val) + list (cons + (cond ((null (or F p)) + key) + ((eq t ent) + (concat key "/")) + ((cond + ((null F) + key) + ((stringp ent) + (concat key "@")) + ((null modes) + key) + ((eq (string-to-char modes) ?s) + ;; a socket + (concat key "=")) + ((or + (memq (elt modes 3) '(?x ?s ?t)) + (memq (elt modes 6) '(?x ?s ?t)) + (memq (elt modes 9) '(?x ?s ?t))) + (concat key "*")) + (t + key)))) + list))))) + file-table) + (setq list (sort list 'string<)) + (if (or C x) + (efs-format-columns-of-files list x) + (concat (mapconcat 'identity list "\n") "\n"))))) + +;;; Store converters. + +;; The cheaters. +(efs-add-ls-converter "-al" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-Al" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-alF" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-AlF" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) + +(efs-add-ls-converter "-alt" "-al" 'efs-t-converter) +(efs-add-ls-converter "-Alt" "-Al" 'efs-t-converter) +(efs-add-ls-converter "-lt" "-l" 'efs-t-converter) +(efs-add-ls-converter "-altF" "-alF" 'efs-t-converter) +(efs-add-ls-converter "-AltF" "-AlF" 'efs-t-converter) +(efs-add-ls-converter "-ltF" "-lF" 'efs-t-converter) +(efs-add-ls-converter "-alt" nil 'efs-t-converter) +(efs-add-ls-converter "-altF" nil 'efs-t-converter) +(efs-add-ls-converter "-Alt" nil 'efs-t-converter) ; cheating a bit +(efs-add-ls-converter "-AltF" nil 'efs-t-converter) ; cheating a bit + +(efs-add-ls-converter "-altr" "-al" 'efs-rt-converter) +(efs-add-ls-converter "-Altr" "-Al" 'efs-rt-converter) +(efs-add-ls-converter "-ltr" "-l" 'efs-rt-converter) +(efs-add-ls-converter "-altFr" "-alF" 'efs-rt-converter) +(efs-add-ls-converter "-AltFr" "-AlF" 'efs-rt-converter) +(efs-add-ls-converter "-ltFr" "-lF" 'efs-rt-converter) +(efs-add-ls-converter "-altr" nil 'efs-rt-converter) +(efs-add-ls-converter "-Altr" nil 'efs-rt-converter) + +(efs-add-ls-converter "-alr" "-alt" 'efs-alpha-converter) +(efs-add-ls-converter "-Alr" "-Alt" 'efs-alpha-converter) +(efs-add-ls-converter "-lr" "-lt" 'efs-alpha-converter) +(efs-add-ls-converter "-alFr" "-alFt" 'efs-alpha-converter) +(efs-add-ls-converter "-AlFr" "-AlFt" 'efs-alpha-converter) +(efs-add-ls-converter "-lFr" "-lFt" 'efs-alpha-converter) + +(efs-add-ls-converter "-al" "-alt" 'efs-alpha-converter) +(efs-add-ls-converter "-Al" "-Alt" 'efs-alpha-converter) +(efs-add-ls-converter "-l" "-lt" 'efs-alpha-converter) +(efs-add-ls-converter "-alF" "-alFt" 'efs-alpha-converter) +(efs-add-ls-converter "-AlF" "-AlFt" 'efs-alpha-converter) +(efs-add-ls-converter "-lF" "-lFt" 'efs-alpha-converter) +(efs-add-ls-converter nil "-alt" 'efs-alpha-converter) + +(efs-add-ls-converter "-alr" "-al" 'efs-ralpha-converter) +(efs-add-ls-converter "-Alr" "-Al" 'efs-ralpha-converter) +(efs-add-ls-converter "-lr" "-l" 'efs-ralpha-converter) +(efs-add-ls-converter "-alFr" "-alF" 'efs-ralpha-converter) +(efs-add-ls-converter "-lAFr" "-lAF" 'efs-ralpha-converter) +(efs-add-ls-converter "-lFr" "-lF" 'efs-ralpha-converter) +(efs-add-ls-converter "-alr" nil 'efs-ralpha-converter) + +(efs-add-ls-converter "-alr" "-alt" 'efs-ralpha-converter) +(efs-add-ls-converter "-Alr" "-Alt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lr" "-lt" 'efs-ralpha-converter) +(efs-add-ls-converter "-alFr" "-alFt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lAFr" "-lAFt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lFr" "-lFt" 'efs-ralpha-converter) + +(efs-add-ls-converter "-alS" "-al" 'efs-S-converter) +(efs-add-ls-converter "-AlS" "-Al" 'efs-S-converter) +(efs-add-ls-converter "-lS" "-l" 'efs-S-converter) +(efs-add-ls-converter "-alSF" "-alF" 'efs-S-converter) +(efs-add-ls-converter "-AlSF" "-AlF" 'efs-S-converter) +(efs-add-ls-converter "-lSF" "-lF" 'efs-S-converter) +(efs-add-ls-converter "-alS" nil 'efs-S-converter) + +(efs-add-ls-converter "-alSr" "-al" 'efs-rS-converter) +(efs-add-ls-converter "-AlSr" "-Al" 'efs-rS-converter) +(efs-add-ls-converter "-lSr" "-l" 'efs-rS-converter) +(efs-add-ls-converter "-alSFr" "-alF" 'efs-rS-converter) +(efs-add-ls-converter "-AlSFr" "-AlF" 'efs-rS-converter) +(efs-add-ls-converter "-lSFr" "-lF" 'efs-rS-converter) +(efs-add-ls-converter "-alSr" nil 'efs-rS-converter) + +(efs-add-ls-converter "-alS" "-alt" 'efs-S-converter) +(efs-add-ls-converter "-AlS" "-Alt" 'efs-S-converter) +(efs-add-ls-converter "-lS" "-lt" 'efs-S-converter) +(efs-add-ls-converter "-alSF" "-alFt" 'efs-S-converter) +(efs-add-ls-converter "-AlSF" "-AlFt" 'efs-S-converter) +(efs-add-ls-converter "-lSF" "-lFt" 'efs-S-converter) + +(efs-add-ls-converter "-alSr" "-alt" 'efs-rS-converter) +(efs-add-ls-converter "-AlSr" "-Alt" 'efs-rS-converter) +(efs-add-ls-converter "-lSr" "-lt" 'efs-rS-converter) +(efs-add-ls-converter "-alSFr" "-alFt" 'efs-rS-converter) +(efs-add-ls-converter "-AlSFr" "-AlFt" 'efs-rS-converter) +(efs-add-ls-converter "-lSFr" "-lFt" 'efs-rS-converter) + +(efs-add-ls-converter "-AlX" nil 'efs-X-converter) +(efs-add-ls-converter "-alX" nil 'efs-X-converter) +(efs-add-ls-converter "-AlXr" nil 'efs-rX-converter) +(efs-add-ls-converter "-alXr" nil 'efs-rX-converter) + +(efs-add-ls-converter "-alX" "-al" 'efs-X-converter) +(efs-add-ls-converter "-AlX" "-Al" 'efs-X-converter) +(efs-add-ls-converter "-lX" "-l" 'efs-X-converter) +(efs-add-ls-converter "-alXF" "-alF" 'efs-X-converter) +(efs-add-ls-converter "-AlXF" "-AlF" 'efs-X-converter) +(efs-add-ls-converter "-lXF" "-lF" 'efs-X-converter) + +(efs-add-ls-converter "-alXr" "-al" 'efs-rX-converter) +(efs-add-ls-converter "-AlXr" "-Al" 'efs-rX-converter) +(efs-add-ls-converter "-lXr" "-l" 'efs-rX-converter) +(efs-add-ls-converter "-alXFr" "-alF" 'efs-rX-converter) +(efs-add-ls-converter "-AlXFr" "-AlF" 'efs-rX-converter) +(efs-add-ls-converter "-lXFr" "-lF" 'efs-rX-converter) + +;;; Converters for efs-files-hashtable + +(efs-add-ls-converter + "" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil nil nil regexp)))) +(efs-add-ls-converter + "-C" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil nil t regexp)))) +(efs-add-ls-converter + "-F" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + t nil nil nil nil nil regexp)))) +(efs-add-ls-converter + "-p" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil t nil nil regexp)))) +(efs-add-ls-converter + "-CF" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + t nil nil nil nil t regexp)))) +(efs-add-ls-converter + "-Cp" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil nil t nil t regexp)))) +(efs-add-ls-converter + "-x" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil t nil regexp)))) +(efs-add-ls-converter + "-xF" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil nil nil t nil regexp)))) +(efs-add-ls-converter + "-xp" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil nil t t nil regexp)))) +(efs-add-ls-converter + "-Ca" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil nil nil t regexp)))) +(efs-add-ls-converter + "-CFa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t t nil nil nil t regexp)))) +(efs-add-ls-converter + "-Cpa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil t nil t regexp)))) +(efs-add-ls-converter + "-xa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil nil t nil regexp)))) +(efs-add-ls-converter + "-xFa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t t nil nil t nil regexp)))) +(efs-add-ls-converter + "-xpa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil t t nil regexp)))) +(efs-add-ls-converter + "-CA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t nil nil t regexp)))) +(efs-add-ls-converter + "-CFA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil t nil nil t regexp)))) +(efs-add-ls-converter + "-CpA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t t nil t regexp)))) +(efs-add-ls-converter + "-xA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t nil t nil regexp)))) +(efs-add-ls-converter + "-xFA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil t nil t nil regexp)))) +(efs-add-ls-converter + "-xpA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t t t nil regexp)))) + +;;;; ------------------------------------------------------------ +;;;; Directory Listing Parsers +;;;; ------------------------------------------------------------ + +(defconst efs-unix:dl-listing-regexp + "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") + +;; Note to progammers: +;; Below are a series of macros and functions used for parsing unix +;; file listings. They are intended only to be used together, so be careful +;; about using them out of context. + +(defmacro efs-ls-parse-file-line () + ;; Extract the filename, size, and permission string from the current + ;; line of a dired-like listing. Assumes that the point is at + ;; the beginning of the line, leaves it just before the size entry. + ;; Returns a list (name size perm-string nlinks owner). + ;; If there is no file on the line, returns nil. + (` (let ((eol (save-excursion (end-of-line) (point))) + name size modes nlinks owner) + (skip-chars-forward " 0-9" eol) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) + (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-month-and-time-regexp eol t) + (setq name (buffer-substring (point) eol) + size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (list name size modes nlinks owner))))) + +(defun efs-relist-symlink (host user symlink path switches) + ;; Does a re-list of a single symlink in efs-data-buffer-name-2, + ;; HOST = remote host + ;; USER = remote username + ;; SYMLINK = symbolic link name as a remote fullpath + ;; PATH = efs full path syntax for the dir. being listed + ;; SWITCHES = ls switches to use for the re-list + ;; Returns (symlink-name symlink-target), as given by the listing. Returns + ;; nil if the listing fails. + ;; Does NOT correct for any symlink marking. + (let* ((temp (efs-make-tmp-name host nil)) + (temp-file (car temp)) + (default-major-mode 'fundamental-mode) + spot) + (unwind-protect + (and + (prog1 + (null + (car + (efs-send-cmd host user + (list 'dir symlink (cdr temp) switches) + (format "Listing %s" + (efs-relativize-filename + (efs-replace-path-component + path symlink)))))) + ;; Put the old message back. + (if (and efs-verbose + (not (and (boundp 'dired-in-query) dired-in-query))) + (message "Listing %s..." + (efs-relativize-filename path)))) + (save-excursion + (if (efs-ftp-path temp-file) + (efs-add-file-entry (efs-host-type efs-gateway-host) + temp-file nil nil nil)) + (set-buffer (get-buffer-create efs-data-buffer-name-2)) + (erase-buffer) + (if (or (file-readable-p temp-file) + (sleep-for efs-retry-time) + (file-readable-p temp-file)) + (let (efs-verbose) + (insert-file-contents temp-file)) + (efs-error host user + (format + "list data file %s not readable" temp-file))) + (skip-chars-forward " 0-9") + (and + (eq (following-char) ?l) + (re-search-forward efs-month-and-time-regexp nil t) + (setq spot (point)) + (re-search-forward " -> " nil t) + (progn + (end-of-line) + (list + ;; We might get the full path in the listing. + (file-name-nondirectory + (buffer-substring spot (match-beginning 0))) + (buffer-substring (match-end 0) (point))))))) + (efs-del-tmp-name temp-file)))) + +(defun efs-ls-sysV-p (host user dir linkname path) + ;; Returns t if the symlink is listed in sysV style. i.e. The + ;; symlink name is marked with an @. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory being listed as a remote full path. + ;; LINKNAME = relative name of symbolic link as derived from an ls -..F... + ;; this is assumed to end with an @ + ;; PATH = efs full path synatx for the directory + (let ((link (car (efs-relist-symlink + host user + (concat dir (substring linkname 0 -1)) + path "-lFd" )))) + (and link (string-equal link linkname)))) + +(defun efs-ls-next-p (host user dir linkname target path) + ;; Returns t is the symlink is marked in the NeXT style. + ;; i.e. The symlink destination is marked with an @. + ;; This assumes that the host-type has already been identified + ;; as NOT sysV-unix, and that target ends in an "@". + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory being listed, as a remore full path + ;; LINKNAME = relative name of symbolic link + ;; Since we've eliminated sysV, it won't be marked with an @ + ;; TARGET = target of symbolic link, as derived from an ls -..F.. + ;; PATH = directory being listed in full efs path syntax. + (let ((no-F-target (nth 1 (efs-relist-symlink + host user + (concat dir linkname) + path "-ld")))) + (and no-F-target + (string-equal (concat no-F-target "@") target)))) + +;; This deals with the F switch. Should also do something about +;; unquoting names obtained with the SysV b switch and the GNU Q +;; switch. See Sebastian's dired-get-filename. + +(defun efs-ls-parser (host-type host user dir path switches) + ;; Meant to be called by efs-parse-listing. + ;; Assumes that point is at the beginning of the first file line. + ;; Assumes that SWITCHES has already been bound to nil for a dumb host. + ;; HOST-TYPE is the remote host-type + ;; HOST is the remote host name + ;; USER is the remote user name + ;; DIR is the remote directory as a full path + ;; PATH is the directory in full efs syntax, and directory syntax. + ;; SWITCHES is the ls listing switches + (let ((tbl (efs-make-hashtable)) + (used-F (and switches (string-match "F" switches))) + (old-tbl (efs-get-files-hashtable-entry path)) + file-type symlink directory file size modes nlinks owner) + (while (setq file (efs-ls-parse-file-line)) + (setq size (nth 1 file) + modes (nth 2 file) + nlinks (nth 3 file) + owner (nth 4 file) + file (car file) + file-type (string-to-char modes) + directory (eq file-type ?d)) + (if (eq file-type ?l) + (if (string-match " -> " file) + (setq symlink (substring file (match-end 0)) + file (substring file 0 (match-beginning 0))) + ;; Shouldn't happen + (setq symlink "")) + (setq symlink nil)) + (if used-F + ;; The F-switch jungle + (let ((socket (eq file-type ?s)) + (fifo (eq file-type ?p)) + (executable + (and (not symlink) ; x bits don't mean a thing for symlinks + (or (memq (elt modes 3) '(?x ?s ?t)) + (memq (elt modes 6) '(?x ?s ?t)) + (memq (elt modes 9) '(?x ?s ?t)))))) + ;; Deal with marking of directories, executables, and sockets. + (if (or (and executable (string-match "*$" file)) + (and socket (string-match "=$" file)) + (and fifo (string-match "|$" file))) + (setq file (substring file 0 -1)) + ;; Do the symlink dance. + (if symlink + (let ((fat-p (string-match "@$" file)) + (sat-p (string-match "@$" symlink))) + (cond + ;; Those that mark the file + ((and (memq host-type '(sysV-unix apollo-unix)) fat-p) + (setq file (substring file 0 -1))) + ;; Those that mark nothing + ((memq host-type '(bsd-unix dumb-unix))) + ;; Those that mark the target + ((and (eq host-type 'next-unix) sat-p) + (setq symlink (substring symlink 0 -1))) + ;; We don't know + ((eq host-type 'unix) + (if fat-p + (cond + ((efs-ls-sysV-p host user dir + file path) + (setq host-type 'sysV-unix + file (substring file 0 -1)) + (efs-add-host 'sysV-unix host) + (efs-add-listing-type 'sysV-unix host user)) + ((and sat-p + (efs-ls-next-p host user dir file symlink + path)) + (setq host-type 'next-unix + symlink (substring symlink 0 -1)) + (efs-add-host 'next-unix host) + (efs-add-listing-type 'next-unix host user)) + (t + (setq host-type 'bsd-unix) + (efs-add-host 'bsd-unix host) + (efs-add-listing-type 'bsd-unix host user))) + (if (and sat-p + (efs-ls-next-p host user dir file + symlink path)) + (progn + (setq host-type 'next-unix + symlink (substring symlink 0 -1)) + (efs-add-host 'next-unix host) + (efs-add-listing-type 'next-unix host user)) + (setq host-type 'bsd-unix) + (efs-add-host 'bsd-unix host) + (efs-add-listing-type 'bsd-unix host user))))) + ;; Look out for marking of symlink + ;; If we really wanted to, at this point we + ;; could distinguish aix from hp-ux, ultrix, irix and a/ux, + ;; allowing us to skip the re-list in the future, for the + ;; later 4 host types. Another version... + (if (string-match "[=|*]$" symlink) + (let ((relist (efs-relist-symlink + host user (concat dir file) + path "-dl"))) + (if relist (setq symlink (nth 1 relist)))))))))) + ;; Strip / off the end unconditionally. It's not a valid file character + ;; anyway. + (if (string-match "/$" file) (setq file (substring file 0 -1))) + (let ((mdtm (and old-tbl (nth 5 (efs-get-hash-entry file old-tbl))))) + (if mdtm + (efs-put-hash-entry file (list (or symlink directory) size owner + modes nlinks mdtm) tbl) + (efs-put-hash-entry file (list (or symlink directory) size owner + modes nlinks) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)) + +(efs-defun efs-parse-listing nil (host user dir path &optional switches) + ;; Parse the a listing which is assumed to be from some type of unix host. + ;; Note that efs-key will be bound to the actual host type. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches used for the listing + (efs-save-match-data + (cond + ;; look for total line + ((looking-at "^total [0-9]+$") + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + (efs-ls-parser efs-key host user dir path switches)) + ;; look for errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + nil) + ((eobp) ; i.e. zerop buffer-size + nil) ; assume an ls error message + ;; look for listings without total lines + ((re-search-forward efs-month-and-time-regexp nil t) + (beginning-of-line) + (efs-ls-parser efs-key host user dir path switches)) + (t nil)))) + +(efs-defun efs-parse-listing unix:unknown + (host user dir path &optional switches) + ;; Parse the a listing which is assumed to be from some type of unix host, + ;; possibly one doing a dl listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches used for the listing + (efs-save-match-data + (cond + ;; look for total line + ((looking-at "^total [0-9]+$") + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + ;; This will make the listing-type track the host-type. + (efs-add-listing-type nil host user) + (efs-ls-parser 'unix host user dir path switches)) + ;; look for errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + nil) + ((eobp) ; i.e. zerop buffer-size + nil) ; assume an ls error message + ;; look for listings without total lines + ((and (re-search-forward efs-month-and-time-regexp nil t) + (progn + (beginning-of-line) + (looking-at efs-modes-links-owner-regexp))) + (efs-add-listing-type nil host user) + (efs-ls-parser 'unix host user dir path switches)) + ;; look for dumb listings + ((re-search-forward + (concat (regexp-quote switches) + " not found\\|\\(^ls: +illegal option -- \\)") + (save-excursion (end-of-line) (point)) t) + (if (eq (efs-host-type host) 'apollo-unix) + (progn + (efs-add-host 'dumb-apollo-unix host) + (efs-add-listing-type 'dumb-apollo-unix host user)) + (efs-add-host 'dumb-unix host) + (efs-add-listing-type 'dumb-unix host user)) + (if (match-beginning 1) + ;; Need to try to list again. + (let ((efs-ls-uncache t)) + (efs-ls + path nil (format "Relisting %s" (efs-relativize-filename path)) t) + (goto-char (point-min)) + (efs-parse-listing nil host user dir path switches)) + (if (re-search-forward "^total [0-9]+$" nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (efs-ls-parser 'dumb-unix host user dir path switches))))) + ;; Look for dl listings. + ((re-search-forward efs-unix:dl-listing-regexp nil t) + (efs-add-host 'unix host) + (efs-add-listing-type 'unix:dl host user) + (efs-parse-listing 'unix:dl host user dir path switches)) + ;; don't know, return nil + (t nil)))) + +(defun efs-ls-parse-1-liner (filename buffer &optional symlink) + ;; Parse a 1-line listing for FILENAME in BUFFER, and update + ;; the cached info for FILENAME. + ;; Optional SYMLINK arg gives the expected target of a symlink. + ;; Since one-line listings are usually used to update info for + ;; newly created files, we usually know what sort of a file to expect. + ;; Actually trying to parse out the symlink target could be impossible + ;; for some types of switches. + (efs-save-buffer-excursion + (set-buffer buffer) + (goto-char (point-min)) + (skip-chars-forward " 0-9") + (efs-save-match-data + (let (modes nlinks owner size) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-month-and-time-regexp nil t) + (setq size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (let* ((filename (directory-file-name filename)) + (files (efs-get-files-hashtable-entry + (file-name-directory filename)))) + (if files + (let* ((key (efs-get-file-part filename)) + (ignore-case (memq (efs-host-type + (car (efs-ftp-path filename))) + efs-case-insensitive-host-types)) + (ent (efs-get-hash-entry key files ignore-case)) + (mdtm (nth 5 ent)) + type) + (if (= (string-to-char modes) ?l) + (setq type + (cond + ((stringp symlink) + symlink) + ((stringp (car ent)) + (car ent)) + (t ; something weird happened. + ""))) + (if (= (string-to-char modes) ?d) + (setq type t))) + (efs-put-hash-entry + key (list type size owner modes nlinks mdtm) + files ignore-case))))))))) + +(efs-defun efs-update-file-info nil (file buffer &optional symlink) + "For FILE, update cache information from a single file listing in BUFFER." + ;; By default, this does nothing. + nil) + +(efs-defun efs-update-file-info unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info sysV-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info bsd-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info next-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info apollo-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info dumb-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info dumb-apollo-unix + (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info super-dumb-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) + +;;;; ---------------------------------------------------------------- +;;;; The 'unknown listing parser. This does some host-type guessing. +;;;; ---------------------------------------------------------------- + +;;; Regexps for host and listing type guessing from the listing syntax. + +(defconst efs-ka9q-listing-regexp + (concat + "^\\([0-9,.]+\\|No\\) files\\. [0-9,.]+ bytes free\\. " + "Disk size [0-9,]+ bytes\\.$")) +;; This version of the regexp is really for hosts which allow some switches, +;; but not ours. Rather than determine which switches we could be using +;; we just assume that it's dumb. +(defconst efs-dumb-unix-listing-regexp + (concat + "^[Uu]sage: +ls +-[a-zA-Z0-9]+[ \n]\\|" + ;; Unitree server + "^Error getting stats for \"-[a-zA-Z0-9]+\"")) + +(defconst efs-dos-distinct-date-and-time-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " + "[ 12][0-9]:[0-5][0-9] ")) +;; Regexp to match the output from the hellsoft ftp server to an +;; ls -al. Unfortunately, this looks a lot like some unix ls error +;; messages. +(defconst efs-hell-listing-regexp + (concat + "ls: file or directory not found\n\\'\\|" + "[-d]\\[[-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z]\\]")) + +(efs-defun efs-parse-listing unknown + (host user dir path &optional switches) + "Parse the current buffer which is assumed to contain a dir listing. +Return a hashtable as the result. If the listing is not really a +directory listing, then return nil. + +HOST is the remote host's name. +USER is the remote user name. +DIR is the directory as a full remote path. +PATH is the directory in full efs path synatx. +SWITCHES are the switches passed to ls. If SWITCHES is nil, then a +dumb \(with dir\) listing has been done." + (efs-save-match-data + (cond + + ;; look for total line + ((looking-at "^total [0-9]+$") + (efs-add-host 'unix host) + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + (efs-ls-parser 'unix host user dir path switches)) + + ;; Look for hellsoft. Need to do this before looking + ;; for ls errors, since the hellsoft output looks a lot like an ls error. + ((looking-at efs-hell-listing-regexp) + (if (null (car (efs-send-cmd host user '(quote site dos)))) + (let* ((key (concat host "/" user "/~")) + (tilde (efs-get-hash-entry + key efs-expand-dir-hashtable))) + (efs-add-host 'hell host) + ;; downcase the expansion of ~ + (if (and tilde (string-match "^[^a-z]+$" tilde)) + (efs-put-hash-entry key (downcase tilde) + efs-expand-dir-hashtable)) + ;; Downcase dir, in case its got some upper case stuff in it. + (setq dir (downcase dir) + path (efs-replace-path-component path dir)) + (let ((efs-ls-uncache t)) + ;; This will force the data buffer to be re-filled + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'hell host user dir path)) + ;; Don't know, give unix a try. + (efs-add-host 'unix host) + nil)) + + ;; look for ls errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + (efs-add-host 'unix host) + nil) + + ((eobp) ; i.e. (zerop (buffer-size)) + ;; This could be one of: + ;; (1) An Ultrix ls error message + ;; (2) A listing with the A switch of an empty directory + ;; on a machine which doesn't give a total line. + ;; (3) The result of an attempt at an nlist. (This would mean a + ;; dumb host.) + ;; (4) The twilight zone. + (cond + ((save-excursion + (set-buffer (process-buffer + (efs-get-process host user))) + (save-excursion + (goto-char (point-max)) + (and + ;; The dir ftp output starts with a 200 cmd. + (re-search-backward "^150 " nil t) + ;; We never do an nlist (it's a short listing). + ;; If the machine thinks that we did, it's dumb. + (looking-at "[^\n]+ NLST ")))) + ;; It's dumb-unix or ka9q. Anything else? + ;; This will re-fill the data buffer with a dumb listing. + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (cond + ;; check for dumb-unix + ((re-search-forward efs-month-and-time-regexp nil t) + (efs-add-host 'dumb-unix host) + (beginning-of-line) + (efs-parse-listing 'dumb-unix host user dir path)) + ;; check for ka9q + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at efs-ka9q-listing-regexp)) + (efs-add-host 'ka9q host) + (efs-parse-listing 'ka9q host user dir path)) + (t ; Don't know, try unix. + (efs-add-host 'unix host) + nil))) + ;; check for Novell Netware + ((null (car (efs-send-cmd host user '(quote site nfs)))) + (efs-add-host 'netware host) + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'netware host user dir path)) + (t + ;; Assume (1), an Ultrix error message. + (efs-add-host 'unix host) + nil))) + + ;; unix without a total line + ((re-search-forward efs-month-and-time-regexp nil t) + (efs-add-host 'unix host) + (beginning-of-line) + (efs-ls-parser 'unix host user dir path switches)) + + ;; Now we look for host-types, or listing-types which are auto-rec + ;; by the listing parser, because it's not possible to pick them out + ;; from a pwd. + + ;; check for dumb-unix + ;; (Guessing of dumb-unix hosts which return an ftp error message is + ;; done in efs-ls.) + ((re-search-forward efs-dumb-unix-listing-regexp nil t) + (efs-add-host 'dumb-unix host) + ;; This will force the data buffer to be re-filled + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'dumb-unix host user dir path)) + + ;; check for Distinct's DOS ftp server + ((re-search-forward efs-dos-distinct-date-and-time-regexp nil t) + (efs-add-host 'dos-distinct host) + (efs-parse-listing 'dos-distinct host user dir path)) + + ;; check for KA9Q pseudo-unix (LINUX?) + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at efs-ka9q-listing-regexp)) + (efs-add-host 'ka9q host) + ;; This will re-fill the data buffer. + ;; Need to do this because ka9q is a dumb host. + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'ka9q host user dir path)) + + ;; Check for a unix descriptive (dl) listing + ;; Do this last, because it's hard to guess. + ((re-search-forward efs-unix:dl-listing-regexp nil t) + (efs-add-host 'unix host) + (efs-add-listing-type 'unix:dl host user) + (efs-parse-listing 'unix:dl host user dir path switches)) + + ;; Don't know what's going on. Return nil, and assume unix. + (t + (efs-add-host 'unix host) + nil)))) + +;;;; ------------------------------------------------------------ +;;;; Directory information hashtable. +;;;; ------------------------------------------------------------ + +(efs-defun efs-really-file-p nil (file ent) + ;; efs-files-hashtable sometimes contains fictitious entries, when + ;; some OS's allow a file to be accessed by another name. For example, + ;; in VMS the highest version of a file may be accessed by omitting the + ;; the file version number. This function should return t if the + ;; filename FILE is really a file. ENT is the hash entry of the file. + t) + +(efs-defun efs-add-file-entry nil (path type size owner + &optional modes nlinks mdtm) + ;; Add a new file entry for PATH + ;; TYPE is nil for a plain file, t for a directory, and a string + ;; (the target of the link) for a symlink. + ;; SIZE is the size of the file in bytes. + ;; OWNER is the owner of the file, as a string. + ;; MODES is the file modes, as a string. In Unix, this will be 10 cars. + ;; NLINKS is the number of links for the file. + ;; MDTM is the last modtime obtained for the file. This is for + ;; short-term cache only, as emacs often has sequences of functions + ;; doing modtime lookup. If you really want to be sure of the modtime, + ;; use efs-get-file-mdtm, which asks the remote server. + + (and (eq type t) + (setq path (directory-file-name path))) + (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) + (if files + (efs-put-hash-entry + (efs-get-file-part path) + (cond (mdtm + (list type size owner modes nlinks + mdtm)) + (nlinks + (list type size owner modes nlinks)) + (modes (list type size owner modes)) + (t (list type size owner))) + files + (memq efs-key efs-case-insensitive-host-types))) + (efs-del-from-ls-cache path t nil))) + +(efs-defun efs-delete-file-entry nil (path &optional dir-p) + "Delete the file entry for PATH, if its directory info exists." + (if dir-p + (progn + (setq path (file-name-as-directory path)) + (efs-del-hash-entry (efs-canonize-file-name path) + efs-files-hashtable) + ;; Note that file-name-as-directory followed by + ;; (substring path 0 -1) + ;; serves to canonicalize directory file names to their unix form. + ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO + ;; PATH is supposed to be s fully expanded efs-style path. + (setq path (substring path 0 -1)))) + (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) + (if files + (efs-del-hash-entry + (efs-get-file-part path) + files + (memq (efs-host-type (car (efs-ftp-path path))) + efs-case-insensitive-host-types)))) + (efs-del-from-ls-cache path t nil) + (if dir-p (efs-del-from-ls-cache path nil t))) + +(defun efs-set-files (directory files) + "For DIRECTORY, set or change the associated FILES hashtable." + (if files + (efs-put-hash-entry + (efs-canonize-file-name (file-name-as-directory directory)) + files efs-files-hashtable))) + +(defun efs-parsable-switches-p (switches &optional full-dir) + ;; Returns non-nil if SWITCHES would give an ls listing suitable for parsing + ;; If FULL-DIR is non-nil, the switches must be suitable for parsing a full + ;; ditectory. + (or (null switches) + (efs-save-match-data + (and (string-match "[aA]" switches) + ;; g is not good enough, need l or o for owner. + (string-match "[lo]" switches) + ;; L shows link target, rather than link. We need both. + (not (string-match "[RfL]" switches)) + (not (and full-dir (string-match "d" switches))))))) + +(defun efs-get-files (directory &optional no-error) + "For DIRECTORY, return a hashtable of file entries. +This will give an error or return nil, depending on the value of +NO-ERROR, if a listing for DIRECTORY cannot be obtained." + (let ((directory (file-name-as-directory directory))) + (or (efs-get-files-hashtable-entry directory) + (and (efs-ls directory (efs-ls-guess-switches) t 'parse no-error) + (efs-get-files-hashtable-entry directory))))) + +(efs-defun efs-allow-child-lookup nil (host user dir file) + ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax. + ;; i.e. /foo/bar/, not /foo/bar. + ;; Deal with dired. Anything else? + (not (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal dired-local-variables-file file)))) + +(defmacro efs-ancestral-check (host-type path ignore-case) + ;; Checks to see if something in a path's ancient parentage + ;; would make it impossible for the path to exist in the directory + ;; tree. In this case it returns nil. Otherwise returns t (there + ;; is essentially no information returned in this case, the file + ;; may exist or not). + ;; This macro should make working with RCS more efficient. + ;; It also helps with FTP servers that go into fits if we ask to + ;; list a non-existent dir. + ;; Yes, I know that the function mapped over the hashtable can + ;; be written more cleanly with a concat, but this is faster. + ;; concat's cause a lot of consing. So do regexp-quote's, but we can't + ;; avoid it. + ;; Probably doesn't make much sense for this to be an efs-defun, since + ;; the host-type dependence is very mild. + (` + (let ((path (, path)) ; expand once + (ignore-case (, ignore-case)) + str) + ;; eliminate flat file systems -- should have a constant for this + (or (memq (, host-type) '(mts cms mvs cms-knet)) + (efs-save-match-data + (catch 'foo + (efs-map-hashtable + (function + (lambda (key val) + (and (eq (string-match (regexp-quote key) path) 0) + (setq str (substring path (match-end 0))) + (string-match "^[^/]+" str) + (not (efs-hash-entry-exists-p + (substring str 0 (match-end 0)) + val ignore-case)) + (throw 'foo nil)))) + efs-files-hashtable) + t)))))) + +(defun efs-file-entry-p (path) + ;; Return whether there is a file entry for PATH. + ;; Under no circumstances does this cause FTP activity. + (let* ((path (directory-file-name (efs-canonize-file-name path))) + (dir (file-name-directory path)) + (file (efs-get-file-part path)) + (tbl (efs-get-files-hashtable-entry dir))) + (and tbl (efs-hash-entry-exists-p + file tbl + (memq (efs-host-type (car (efs-ftp-path dir))) + efs-case-insensitive-host-types)) t))) + +(defun efs-get-file-entry (path) + "Return the given file entry for PATH. +This is a list of the form \(type size owner modes nlinks modtm\), +where type is nil for a normal file, t for a directory, and a string for a +symlink, size is the size of the file in bytes, if known, and modes are +the permission modes of the file as a string. modtm is short-term the +cache of the file modtime. It is not used by `verify-visited-file-modtime'. +If the file isn't in the hashtable, this returns nil." + (let* ((path (directory-file-name (efs-canonize-file-name path))) + (dir (file-name-directory path)) + (file (efs-get-file-part path)) + (parsed (efs-ftp-path dir)) + (host (car parsed)) + (host-type (efs-host-type host)) + (ent (efs-get-files-hashtable-entry dir)) + (ignore-case (memq host-type efs-case-insensitive-host-types))) + (if ent + (efs-get-hash-entry file ent ignore-case) + (let ((user (nth 1 parsed)) + (r-dir (nth 2 parsed))) + (and (efs-ancestral-check host-type path ignore-case) + (or (and efs-allow-child-lookup + (efs-allow-child-lookup host-type + host user r-dir file) + (setq ent (efs-get-files path t)) + (efs-get-hash-entry "." ent)) + ;; i.e. it's a directory by child lookup + (efs-get-hash-entry + file (efs-get-files dir) ignore-case))))))) + +(defun efs-wipe-file-entries (host user) + "Remove cache data for all files on HOST and USER. +This replaces the file entry information hashtable with one that +doesn't have any entries for the given HOST, USER pair." + (let ((new-tbl (efs-make-hashtable (length efs-files-hashtable))) + (host (downcase host)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types))) + (if case-fold (setq user (downcase user))) + (efs-map-hashtable + (function + (lambda (key val) + (let ((parsed (efs-ftp-path key))) + (if parsed + (let ((h (nth 0 parsed)) + (u (nth 1 parsed))) + (or (and (string-equal host (downcase h)) + (string-equal user (if case-fold (downcase u) u))) + (efs-put-hash-entry key val new-tbl))))))) + efs-files-hashtable) + (setq efs-files-hashtable new-tbl))) + + +;;;; ============================================================ +;;;; >8 +;;;; Redefinitions of standard GNU Emacs functions. +;;;; ============================================================ + +;;;; ------------------------------------------------------------ +;;;; expand-file-name and friends... +;;;; ------------------------------------------------------------ + +;; New filename expansion code for efs. +;; The overall structure is based around the following internal +;; functions and macros. Since these are internal, they do NOT +;; call efs-save-match-data. This is done by their calling +;; function. +;; +;; efs-expand-tilde +;; - expands all ~ constructs, both local and remote. +;; efs-short-circuit-file-name +;; - short-circuits //'s and /~'s, for both local and remote paths. +;; efs-de-dot-file-name +;; - canonizes /../ and /./'s in both local and remote paths. +;; +;; The following two functions overload existing emacs functions. +;; They are the entry points to this filename expansion code, and as such +;; call efs-save-match-data. +;; +;; efs-expand-file-name +;; efs-substitute-in-file-name + +;;; utility macros + +(defmacro efs-short-circuit-file-name (filename) + ;; Short-circuits //'s and /~'s in filenames. + ;; Returns a list consisting of the local path, + ;; host-type, host, user. For local hosts, + ;; host-type, host, and user are all nil. + (` + (let ((start 0) + (string (, filename)) + backskip regexp lbackskip + lregexp parsed host-type host user) + + (if efs-local-apollo-unix + (setq lregexp ".//+" + lbackskip 2) + (setq lregexp "//+" + lbackskip 1)) + + ;; Short circuit /user@mach: roots. It is important to do this + ;; now to avoid unnecessary ftp connections. + + (while (string-match efs-path-root-short-circuit-regexp string start) + (setq start (1+ (match-beginning 0)))) + (or (zerop start) (setq string (substring string start) + start 0)) + + ;; identify remote root + + (if (setq parsed (efs-ftp-path-macro string)) + (if (memq (setq string (nth 2 parsed) + host-type + (efs-host-type (setq host (car parsed)) + (setq user (nth 1 parsed)))) + '(apollo-unix dumb-apollo-unix)) + (setq regexp ".//+" + backskip 2) + (setq regexp "//+" + backskip 1)) + (setq regexp lregexp + backskip lbackskip)) + + ;; Now short-circuit in an apollo and efs sensitive way. + + (while (cond ((string-match regexp string start) + (setq start (- (match-end 0) backskip))) + ((string-match "/~" string start) + (setq start (1- (match-end 0))))) + + (and host-type + (null efs-short-circuit-to-remote-root) + (setq host-type nil + regexp lregexp + backskip lbackskip))) + (or (zerop start) (setq string (substring string start))) + (list string host-type (and host-type host) (and host-type user))))) + +(defmacro efs-expand-tilde (tilde host-type host user) + ;; Expands a TILDE (~ or ~sandy type construction) + ;; Takes as an arg a filename (not directory name!) + ;; and returns a filename. HOST-TYPE is the type of remote host. + ;; nil is the type of the local host. + (` + (if (, host-type) ; nil host-type is the local machine + (let* ((host (downcase (, host))) + (host-type (, host-type)) + (ignore-case (memq host-type + efs-case-insensitive-host-types)) + (tilde (, tilde)) + (user (, user)) + (key (concat host "/" user "/" tilde)) + (res (efs-get-hash-entry + key efs-expand-dir-hashtable ignore-case))) + (or res + ;; for real accounts on unix systems, use the get trick + (and (not (efs-anonymous-p user)) + (memq host-type efs-unix-host-types) + (let ((line (nth 1 (efs-send-cmd + host user + (list 'get tilde "/dev/null") + (format "expanding %s" tilde))))) + (setq res + (and (string-match efs-expand-dir-msgs line) + (substring line + (match-beginning 1) + (match-end 1)))) + (if res + (progn + (setq res (efs-internal-directory-file-name res)) + (efs-put-hash-entry + key res efs-expand-dir-hashtable ignore-case) + res)))) + (progn + (setq res + (if (string-equal tilde "~") + (car (efs-send-pwd + host-type host user)) + (let* ((home-key (concat host "/" user "/~")) + (home (efs-get-hash-entry + home-key efs-expand-dir-hashtable + ignore-case)) + pwd-result) + (if home + (setq home + (efs-fix-path + host-type + (efs-internal-file-name-as-directory + host-type home))) + (if (setq home + (car + (setq pwd-result + (efs-send-pwd + host-type + host user)))) + (efs-put-hash-entry + home-key + (efs-internal-directory-file-name + (efs-fix-path host-type home 'reverse)) + efs-expand-dir-hashtable ignore-case) + (efs-error host user + (concat "PWD failed: " + (cdr pwd-result))))) + (unwind-protect + (and (efs-raw-send-cd host user + (efs-fix-path + host-type tilde) t) + (car + (efs-send-pwd + host-type host user))) + (efs-raw-send-cd host user home))))) + (if res + (progn + (setq res (efs-internal-directory-file-name + (efs-fix-path host-type res 'reverse))) + (efs-put-hash-entry + key res efs-expand-dir-hashtable ignore-case) + res))) + (if (string-equal tilde "~") + (error "Cannot get home directory on %s" host) + (error "User %s is not known on %s" (substring tilde 1) host)))) + ;; local machine + (efs-real-expand-file-name (, tilde))))) + +(defmacro efs-de-dot-file-name (string) + ;; Takes a string as arguments, and removes /../'s and /./'s. + (` + (let ((string (, string)) + (start 0) + new make-dir) + ;; to make the regexp's simpler, canonicalize to directory name. + (if (setq make-dir (string-match "/\\.\\.?$" string)) + (setq string (concat string "/"))) + (while (string-match "/\\./" string start) + (setq new (concat new + (substring string + start (match-beginning 0))) + start (1- (match-end 0)))) + + (if new (setq string (concat new (substring string start)))) + + (while (string-match "/[^/]+/\\.\\./" string) + ;; Is there a way to avoid all this concating and copying? + (setq string (concat (substring string 0 (1+ (match-beginning 0))) + (substring string (match-end 0))))) + + ;; Do /../ and //../ special cases. They should expand to + ;; / and //, respectively. + (if (string-match "^\\(/+\\)\\.\\./" string) + (setq string (concat (substring string 0 (match-end 1)) + (substring string (match-end 0))))) + + (if (and make-dir + (not (string-match "^/+$" string))) + (substring string 0 -1) + string)))) + +(defun efs-substitute-in-file-name (string) + "Documented as original." + ;; Because of the complicated interaction between short-circuiting + ;; and environment variable substitution, this can't call the macro + ;; efs-short-circuit-file-name. + (efs-save-match-data + (let ((start 0) + var new root backskip regexp lbackskip + lregexp parsed fudge-host-type rstart error) + + (if efs-local-apollo-unix + (setq lregexp ".//+" + lbackskip 2) + (setq lregexp "//+" + lbackskip 1)) + + ;; Subst. existing env variables + (while (string-match "\\$" string start) + (setq new (concat new (substring string start (match-beginning 0))) + start (match-end 0)) + (cond ((eq (string-match "\\$" string start) start) + (setq start (1+ start) + new (concat new "$$"))) + ((eq (string-match "{" string start) start) + (if (and (string-match "}" string start) + (setq var (getenv + (substring string (1+ start) + (1- (match-end 0)))))) + (setq start (match-end 0) + new (concat new var)) + (setq new (concat new "$")))) + ((eq (string-match "[a-zA-Z0-9]+" string start) start) + (if (setq var (getenv + (substring string start (match-end 0)))) + (setq start (match-end 0) + new (concat new var)) + (setq new (concat new "$")))) + ((setq new (concat new "$"))))) + (if new (setq string (concat new (substring string start)) + start 0)) + + ;; Short circuit /user@mach: roots. It is important to do this + ;; now to avoid unnecessary ftp connections. + + (while (string-match efs-path-root-short-circuit-regexp + string start) + (setq start (1+ (match-beginning 0)))) + (or (zerop start) (setq string (substring string start) + start 0)) + + ;; Look for invalid environment variables in the root. If one is found, + ;; we set the host-type to 'unix. Since we can't login in to determine + ;; it. There is a good chance that we will bomb later with an error, + ;; but the day may yet be saved if the root is short-circuited off. + + (if (string-match efs-path-root-regexp string) + (progn + (setq root (substring string 0 (match-end 0)) + start (match-end 0)) + (if (string-match "[^$]\\(\\$\\$\\)*\\$[^$]" root) + (progn + (setq rstart (1- (match-end 0)) + fudge-host-type t) + (cond + ((eq (elt root rstart) ?{) + (setq + error + (if (string-match "}" root rstart) + (concat + "Subsituting non-existent environment variable " + (substring root (1+ rstart) (match-beginning 0))) + "Missing \"}\" in environment-variable substitution"))) + ((eq (string-match "[A-Za-z0-9]+" root rstart) rstart) + (setq + error + (concat + "Subsituting non-existent environment variable " + (substring root rstart (match-beginning 0))))) + (t + (setq + error + "Bad format environment-variable substitution"))))) + (setq root (efs-unquote-dollars root) + parsed (efs-ftp-path root)) + + (if (and (not fudge-host-type) + ;; This may trigger an FTP connection + (memq (efs-host-type (car parsed) (nth 1 parsed)) + '(apollo-unix dumb-apollo-unix))) + (setq regexp ".//+" + backskip 2) + (setq regexp "//+" + backskip 1))) + ;; no root, we're local + (setq regexp lregexp + backskip lbackskip)) + + ;; Now short-circuit in an apollo and efs sensitive way. + + (while (cond ((string-match regexp string start) + (setq start (- (match-end 0) backskip))) + ((string-match "/~" string start) + (setq start (1- (match-end 0))))) + + (and root + (null efs-short-circuit-to-remote-root) + (setq root nil + regexp lregexp + backskip lbackskip))) + + ;; If we still have a bad root, barf. + (if (and root error) (error error)) + + ;; look for non-existent evironment variables in the path + + (if (string-match + "\\([^$]\\|^\\)\\(\\$\\$\\)*\\$\\([^$]\\|$\\)" string start) + (progn + (setq start (match-beginning 3)) + (cond + ((eq (length string) start) + (error "Empty string is an invalid environment variable")) + ((eq (elt string start) ?{) + (if (string-match "}" string start) + (error + "Subsituting non-existent environment variable %s" + (substring string (1+ start) (match-end 0))) + (error + "Missing \"}\" in environment-variable substitution"))) + ((eq (string-match "[A-Za-z0-9]+" string start) start) + (error + "Subsituting non-existent environment variable %s" + (substring string start (match-end 0)))) + (t + (error + "Bad format environment-variable substitution"))))) + + (if root + (concat root + (efs-unquote-dollars + (if (zerop start) + string + (substring string start)))) + (efs-unquote-dollars + (if (zerop start) + string + (substring string start))))))) + +(defun efs-expand-file-name (name &optional default) + "Documented as original." + (let (s-c-res path host user host-type) + (efs-save-match-data + (or (file-name-absolute-p name) + (setq name (concat + (file-name-as-directory + (or default default-directory)) + name))) + (setq s-c-res (efs-short-circuit-file-name name) + path (car s-c-res) + host-type (nth 1 s-c-res) + host (nth 2 s-c-res) + user (nth 3 s-c-res)) + (cond ((string-match "^~[^/]*" path) + (let ((start (match-end 0))) + (setq path (concat + (efs-expand-tilde + (substring path 0 start) + host-type host user) + (substring path start))))) + ((and host-type (not (file-name-absolute-p path))) + ;; We expand the empty string to a directory. + ;; This can be more efficient for filename + ;; completion. It's also consistent with non-unix. + (let ((tilde (efs-expand-tilde + "~" host-type host user))) + (if (string-equal tilde "/") + (setq path (concat "/" path)) + (setq path (concat tilde "/" path)))))) + + (setq path (efs-de-dot-file-name path)) + (if host-type + (format efs-path-format-string user host path) + path)))) + +;;;; ------------------------------------------------------------ +;;;; Other functions for manipulating file names. +;;;; ------------------------------------------------------------ + +(defun efs-internal-file-name-extension (filename) + ;; Returns the extension for file name FN. + (save-match-data + (let ((file (file-name-sans-versions (file-name-nondirectory filename)))) + (if (string-match "\\.[^.]*\\'" file) + (substring file (match-beginning 0)) + "")))) + +(defun efs-file-name-as-directory (name) + ;; version of file-name-as-directory for remote files. + ;; Usually just appends a / if there isn't one already. + ;; For some systems, it may also remove .DIR like extensions. + (let* ((parsed (efs-ftp-path name)) + (file (nth 2 parsed))) + (if (string-equal file "") + name + (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) name)))) + +(efs-defun efs-internal-file-name-as-directory nil (name) + ;; By default, simply adds a trailing /, if there isn't one. + ;; Note that for expanded filenames, it pays to call this rather + ;; than efs-file-name-as-directory. + (let (file-name-handler-alist) + (file-name-as-directory name))) + +(defun efs-file-name-directory (name) + ;; file-name-directory for remote files. Takes care not to + ;; turn /user@host: into /. + (let ((path (nth 2 (efs-ftp-path name))) + file-name-handler-alist) + (if (or (string-equal path "") + (and (= (string-to-char path) ?~) + (not + (efs-save-match-data + (string-match "/" path 1))))) + name + (if (efs-save-match-data + (not (string-match "/" path))) + (efs-replace-path-component name "") + (file-name-directory name))))) + +(defun efs-file-name-nondirectory (name) + ;; Computes file-name-nondirectory for remote files. + ;; For expanded filenames, can just call efs-internal-file-name-nondirectory. + (let ((file (nth 2 (efs-ftp-path name)))) + (if (or (string-equal file "") + (and (= (string-to-char file) ?~) + (not + (efs-save-match-data + (string-match "/" file 1))))) + "" + (if (efs-save-match-data + (not (string-match "/" file))) + file + (efs-internal-file-name-nondirectory name))))) + +(defun efs-internal-file-name-nondirectory (name) + ;; Version of file-name-nondirectory, without the efs-file-handler-function. + ;; Useful to call this, if we have already decomposed the filename. + (let (file-name-handler-alist) + (file-name-nondirectory name))) + +(defun efs-directory-file-name (dir) + ;; Computes directory-file-name for remote files. + ;; Needs to be careful not to turn /foo@bar:/ into /foo@bar: + (let ((parsed (efs-ftp-path dir))) + (if (string-equal "/" (nth 2 parsed)) + dir + (efs-internal-directory-file-name dir)))) + +(defun efs-internal-directory-file-name (dir) + ;; Call this if you want to apply directory-file-name to the remote + ;; part of a efs-style path. Don't call for non-efs-style paths, + ;; as this short-circuits the file-name-handler-alist completely. + (let (file-name-handler-alist) + (directory-file-name dir))) + +(efs-defun efs-remote-directory-file-name nil (dir) + "Returns the file name on the remote system of directory DIR. +If the remote system is not unix, this may not be the same as the file name +of the directory in efs's internal cache." + (directory-file-name dir)) + +(defun efs-file-name-sans-versions (filename &optional keep-backup-versions) + ;; Version of file-name-sans-versions for remote files. + (or (file-name-absolute-p filename) + (setq filename (expand-file-name filename))) + (let ((parsed (efs-ftp-path filename))) + (efs-internal-file-name-sans-versions + (efs-host-type (car parsed) (nth 1 parsed)) + filename keep-backup-versions))) + +(efs-defun efs-internal-file-name-sans-versions nil + (filename &optional keep-backup-versions) + (let (file-name-handler-alist) + (file-name-sans-versions filename keep-backup-versions))) + +(defun efs-diff-latest-backup-file (fn) + ;; Version of diff latest backup file for remote files. + ;; Accomodates non-unix. + ;; Returns the latest backup for fn, according to the numbering + ;; of the backups. Does not check file-newer-than-file-p. + (let ((parsed (efs-ftp-path fn))) + (efs-internal-diff-latest-backup-file + (efs-host-type (car parsed) (nth 1 parsed)) fn))) + +(efs-defun efs-internal-diff-latest-backup-file nil (fn) + ;; Default behaviour is the behaviour in diff.el + (let (file-name-handler-alist) + (diff-latest-backup-file fn))) + +(defun efs-unhandled-file-name-directory (filename) + ;; Calculate a default unhandled directory for an efs buffer. + ;; This is used to compute directories in which to execute + ;; processes. This is relevant to V19 only. Doesn't do any harm for + ;; older versions though. It would be nice if this wasn't such a + ;; kludge. + (file-name-directory efs-tmp-name-template)) + +(defun efs-file-truename (filename) + ;; Calculates a remote file's truename, if this isn't inhibited. + (let ((filename (expand-file-name filename))) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (efs-internal-file-truename filename) + filename))) + +(defun efs-internal-file-truename (filename) + ;; Internal function so that we don't keep checking + ;; efs-compute-remote-buffer-file-truename, etc, as we recurse. + (let ((dir (efs-file-name-directory filename)) + target dirfile) + ;; Get the truename of the directory. + (setq dirfile (efs-directory-file-name dir)) + ;; If these are equal, we have the (or a) root directory. + (or (string= dir dirfile) + (setq dir (efs-file-name-as-directory + (efs-internal-file-truename dirfile)))) + (if (equal ".." (efs-file-name-nondirectory filename)) + (efs-directory-file-name (efs-file-name-directory + (efs-directory-file-name dir))) + (if (equal "." (efs-file-name-nondirectory filename)) + (efs-directory-file-name dir) + ;; Put it back on the file name. + (setq filename (concat dir (efs-file-name-nondirectory filename))) + ;; Is the file name the name of a link? + (setq target (efs-file-symlink-p filename)) + (if target + ;; Yes => chase that link, then start all over + ;; since the link may point to a directory name that uses links. + ;; We can't safely use expand-file-name here + ;; since target might look like foo/../bar where foo + ;; is itself a link. Instead, we handle . and .. above. + (if (file-name-absolute-p target) + (efs-internal-file-truename target) + (efs-internal-file-truename (concat dir target))) + ;; No, we are done! + filename))))) + + +;;;; ---------------------------------------------------------------- +;;;; I/O functions +;;;; ---------------------------------------------------------------- + +(efs-define-fun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because Lucid and FSF do this differently. + ;; This default behaviour is the lowest common denominator. + (setq buffer-file-name filename)) + +(defun efs-write-region (start end filename &optional append visit &rest args) + ;; write-region for remote files. + ;; This version accepts the V19 interpretation for the arg VISIT. + ;; However, making use of this within V18 may cause errors to crop up. + ;; ARGS should catch the MULE coding-system argument. + (if (stringp visit) (setq visit (expand-file-name visit))) + (setq filename (expand-file-name filename)) + (let ((parsed (efs-ftp-path filename)) + ;; Make sure that the after-write-region-hook isn't called inside + ;; the file-handler-alist + (after-write-region-hook nil)) + (if parsed + (let* ((host (car parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + (temp (car (efs-make-tmp-name nil host))) + (type (efs-xfer-type nil nil host-type filename)) + (abbr (and (or (stringp visit) (eq t visit) (null visit)) + (efs-relativize-filename + (if (stringp visit) visit filename)))) + (buffer (current-buffer)) + (b-file-name buffer-file-name) + (mod-p (buffer-modified-p))) + (unwind-protect + (progn + (condition-case err + (progn + (unwind-protect + (let ((executing-macro t)) + ;; let-bind executing-macro to inhibit messaging. + ;; Setting VISIT to 'quiet is more elegant. + ;; But in Emacs 18, doing it this way allows + ;; us to modify the visited file modtime, so + ;; that undo's show the buffer modified. + (apply 'write-region start end + temp nil visit args)) + ;; buffer-modified-p is now correctly set + (setq buffer-file-name b-file-name) + ;; File modtime is bogus, so clear. + (clear-visited-file-modtime)) + (efs-copy-file-internal + temp nil filename parsed (if append 'append t) + nil (and abbr (format "Writing %s" abbr)) + ;; cont + (efs-cont (result line cont-lines) (filename buffer + visit) + (if result + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\"" line) + filename))) + ;; The new file entry will be added by + ;; efs-copy-file-internal. + (cond + ((eq visit t) + ;; This will run asynch. + (efs-save-buffer-excursion + (set-buffer buffer) + (efs-set-buffer-file-name filename) + (efs-set-visited-file-modtime))) + ((stringp visit) + (efs-save-buffer-excursion + (set-buffer buffer) + (efs-set-buffer-file-name visit) + (set-visited-file-modtime))))) + nil type)) + (error + ;; restore buffer-modified-p + (let (file-name-handler-alist) + (set-buffer-modified-p mod-p)) + (signal (car err) (cdr err)))) + (if (or (eq visit t) + (and (stringp visit) + (efs-ftp-path visit))) + (efs-set-buffer-mode))) + (efs-del-tmp-name temp)) + (and abbr (efs-message "Wrote %s" abbr))) + (if (and (stringp visit) (efs-ftp-path visit)) + (progn + (apply 'write-region start end filename append visit args) + (efs-set-buffer-file-name visit) + (efs-set-visited-file-modtime) + (efs-set-buffer-mode)) + (error "efs-write-region called for a local file"))))) + +(defun efs-insert-file-contents (filename &optional visit &rest args) + ;; Inserts file contents for remote files. + ;; The additional ARGS covers V19 BEG and END. Should also handle the + ;; CODING-SYSTEM arg for mule. Hope the two don't trip over each other. + (barf-if-buffer-read-only) + (unwind-protect + (let* ((filename (expand-file-name filename)) + (parsed (efs-ftp-path filename)) + (host (car parsed)) + (host-type (efs-host-type host)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (buffer (current-buffer))) + + (if (or (file-exists-p filename) + (let* ((res (and + (not (efs-get-host-property host 'rnfr-failed)) + (efs-send-cmd + host user (list 'quote 'rnfr path)))) + (line (nth 1 res))) + ;; RNFR returns a 550 if the file doesn't exist. + (if (and line (>= (length line) 4) + (string-equal "550 " (substring line 0 4))) + nil + (if (car res) (efs-set-host-property host 'rnfr-failed t)) + (efs-del-from-ls-cache filename t nil) + (efs-del-hash-entry + (efs-canonize-file-name (file-name-directory filename)) + efs-files-hashtable) + (file-exists-p filename)))) + + (let ((temp (concat + (car (efs-make-tmp-name nil host)) + (efs-internal-file-name-extension filename))) + (type (efs-xfer-type host-type filename nil nil)) + (abbr (efs-relativize-filename filename)) + (temp (concat (car (efs-make-tmp-name nil host)) + (or (substring abbr (string-match "\\." abbr)) ""))) + (i-f-c-size 0)) + + (unwind-protect + (efs-copy-file-internal + filename parsed temp nil t nil + (format "Retrieving %s" abbr) + (efs-cont (result line cont-lines) (filename visit buffer + host-type + temp args) + (if result + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\"" + line) + filename)) + (if (eq host-type 'coke) + (efs-coke-insert-beverage-contents buffer filename + line) + (efs-save-buffer-excursion + (set-buffer buffer) + (if (or (file-readable-p temp) + (sleep-for efs-retry-time) + ;; Wait for file to hopefully appear. + (file-readable-p temp)) + + (setq i-f-c-size + (nth 1 (apply 'insert-file-contents + temp visit args))) + (signal 'ftp-error + (list + "Opening input file:" + (format + "FTP Error: %s not arrived or readable" + filename)))) + ;; This is done asynch + (if visit + (let ((buffer-file-name filename)) + (efs-set-visited-file-modtime))))))) + nil type) + (efs-del-tmp-name temp)) + ;; Return (FILENAME SIZE) + (list filename i-f-c-size)) + (signal 'file-error (list "Opening input file" filename)))) + ;; Set buffer-file-name at the very last, so if anything bombs, we're + ;; not visiting. + (if visit + (efs-set-buffer-file-name filename)))) + +(defun efs-revert-buffer (arg noconfirm) + "Revert this buffer from a remote file using ftp." + (let ((opoint (point))) + (cond ((null buffer-file-name) + (error "Buffer does not seem to be associated with any file")) + ((or noconfirm + (yes-or-no-p (format "Revert buffer from file %s? " + buffer-file-name))) + (let ((buffer-read-only nil)) + ;; Set buffer-file-name to nil + ;; so that we don't try to lock the file. + (let ((buffer-file-name nil)) + (unlock-buffer) + (erase-buffer)) + (insert-file-contents buffer-file-name t)) + (goto-char (min opoint (point-max))) + (after-find-file nil) + t)))) + +(defun efs-recover-file (file) + ;; Version of recover file for remote files, and remote autosave files too. + (if (auto-save-file-name-p file) (error "%s is an auto-save file" file)) + (let* ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name))) + (file-name-parsed (efs-ftp-path file-name)) + (file-parsed (efs-ftp-path file)) + (efs-ls-uncache t)) + (cond ((not (file-newer-than-file-p file-name file)) + (error "Auto-save file %s not current" file-name)) + ((save-window-excursion + (or (eq system-type 'vax-vms) + (progn + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (if file-parsed + (progn + (princ (format "On the host %s:\n" + (car file-parsed))) + (princ + (let ((default-directory exec-directory)) + (efs-ls file (if (file-symlink-p file) + "-lL" "-l") + t t)))) + (princ "On the local host:\n") + (let ((default-directory exec-directory)) + (call-process "ls" nil standard-output nil + (if (file-symlink-p file) "-lL" "-l") + file))) + (princ "\nAUTO SAVE FILE on the ") + (if file-name-parsed + (progn + (princ (format "host %s:\n" + (car file-name-parsed))) + (princ + (efs-ls file-name + (if (file-symlink-p file-name) "-lL" "-l") + t t))) + (princ "local host:\n") + (let ((default-directory exec-directory)) + (call-process "ls" nil standard-output nil + "-l" file-name))) + (princ "\nFile modification times are given in ") + (princ "the local time of each host.\n")) + (save-excursion + (set-buffer "*Directory*") + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (if (> (current-column) (window-width)) + (progn + (skip-chars-backward " \t") + (skip-chars-backward "^ \t\n") + (if (> (current-column) 12) + (progn + (delete-horizontal-space) + (insert "\n "))))) + (forward-line 1)) + (set-buffer-modified-p nil) + (goto-char (point-min))))) + (yes-or-no-p (format "Recover using this auto save file? "))) + (switch-to-buffer (find-file-noselect file t)) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-file-contents file-name nil)) + (after-find-file nil)) + (t (error "Recover-file cancelled.")))) + ;; This is no longer done in V19. However, I like the caution for + ;; remote files, where file-newer-than-file-p may lie. + (setq buffer-auto-save-file-name nil) + (message "Auto-save off in this buffer till you do M-x auto-save-mode.")) + +;;;; ------------------------------------------------------------------ +;;;; Attributes of files. +;;;; ------------------------------------------------------------------ + +(defun efs-file-symlink-p (file) + ;; Version of file-symlink-p for remote files. + ;; Call efs-expand-file-name rather than the normal + ;; expand-file-name to stop loops when using a package that + ;; redefines both file-symlink-p and expand-file-name. + ;; Do not use efs-get-file-entry, because a child-lookup won't do. + (let* ((file (efs-expand-file-name file)) + (ignore-case (memq (efs-host-type (car (efs-ftp-path file))) + efs-case-insensitive-host-types)) + (file-type (car (efs-get-hash-entry + (efs-get-file-part file) + (efs-get-files (file-name-directory file)) + ignore-case)))) + (and (stringp file-type) + (if (file-name-absolute-p file-type) + (efs-replace-path-component file file-type) + file-type)))) + +(defun efs-file-exists-p (path) + ;; file-exists-p for remote file. Uses the cache if possible. + (let* ((path (expand-file-name path)) + (parsed (efs-ftp-path path))) + (efs-internal-file-exists-p (efs-host-type (car parsed) (nth 1 parsed)) + path))) + +(efs-defun efs-internal-file-exists-p nil (path) + (and (efs-get-file-entry path) t)) + +(defun efs-file-directory-p (file) + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file))) + (efs-internal-file-directory-p (efs-host-type (car parsed) (nth 1 parsed)) + file))) + +(efs-defun efs-internal-file-directory-p nil (path) + ;; Version of file-directory-p for remote files. + (let ((parsed (efs-ftp-path path))) + (or (string-equal (nth 2 parsed) "/") ; root is always a directory + (let ((file-ent (car (efs-get-file-entry + (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) + path))))) + ;; We do a file-name-as-directory on path here because some + ;; machines (VMS) use a .DIR to indicate the filename associated + ;; with a directory. This needs to be canonicalized. + (if (stringp file-ent) + (efs-internal-file-directory-p + nil + (efs-chase-symlinks + ;; efs-internal-directory-file-name + ;; only loses for paths where the remote file + ;; is /. This has been eliminated. + (efs-internal-directory-file-name path))) + file-ent))))) + +(defun efs-file-attributes (file) + ;; Returns file-file-attributes for a remote file. + ;; For the file modtime does not return efs's cached value, as that + ;; corresponds to buffer-file-modtime (i.e. the modtime of the file + ;; the last time the buffer was vsisted or saved). Caching modtimes + ;; does not make much sense, as they are usually used to determine + ;; if a cache is stale. The modtime if a remote file can be obtained with + ;; efs-get-file-mdtm. This is _not_ returned for the 5th entry here, + ;; because it requires an FTP transaction, and a priori we don't know + ;; if the caller actually cares about this info. Having file-attributes + ;; return such a long list of info is not well suited to remote files, + ;; as some of this info may be costly to obtain. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (if ent + (let* ((parsed (efs-ftp-path file)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (type (car ent)) + (size (or (nth 1 ent) -1)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + ;; Hack to give remote files a "unique" "inode number". + ;; It's actually the sum of the characters in its name. + ;; It's not even really unique. + (inode (apply '+ + (nconc (mapcar 'identity host) + (mapcar 'identity user) + (mapcar 'identity + (efs-internal-directory-file-name + path))))) + (nlinks (or (nth 4 ent) -1))) ; return -1 if we don't know + (list + (if (and (stringp type) (file-name-absolute-p type)) + (efs-replace-path-component file type) + type) ;0 file type + nlinks ;1 link count + (if owner ;2 uid + ;; Not really a unique integer, + ;; just a half-hearted attempt + (apply '+ (mapcar 'identity owner)) + -1) + -1 ;3 gid + '(0 0) ;4 atime + '(0 0) ;5 mtime + '(0 0) ;6 ctime + size ;7 size + (or modes ;8 mode + (concat + (cond ((stringp type) "l") + (type "d") + (t "-")) + "?????????")) + nil ;9 gid weird (Who knows if the gid + ; would be changed?) + inode ;10 inode + -1 ;11 device number [v19 only] + ))))) + +(defun efs-file-writable-p (file) + ;; file-writable-p for remote files. + ;; Does not attempt to open the file, but just looks at the cached file + ;; modes. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (if (and ent (or (not (stringp (car ent))) + (setq file (efs-chase-symlinks file) + ent (efs-get-file-entry file)))) + (let* ((owner (nth 2 ent)) + (modes (nth 3 ent)) + (parsed (efs-ftp-path file)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-writable-p host-type user owner modes)) + (let ((dir (file-name-directory file))) + (and + (not (string-equal dir file)) + (file-directory-p dir) + (file-writable-p dir)))))) + +(efs-defun efs-internal-file-writable-p nil (user owner modes) + ;; By default, we'll just guess yes. + t) + +(efs-defun efs-internal-file-writable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?w (list (aref modes 2) (aref modes 5) + (aref modes 8))) + (memq ?w (list (aref modes 5) (aref modes 8)))))) + t)) ; guess + +(defun efs-file-readable-p (file) + ;; Version of file-readable-p that works for remote files. + ;; Works by checking efs's cache of the file modes. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (and ent + (or (not (stringp (car ent))) + (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) + ;; file exists + (let* ((parsed (efs-ftp-path file)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-readable-p host-type user owner modes))))) + +(efs-defun efs-internal-file-readable-p nil (user owner modes) + ;; Guess t by default + t) + +(efs-defun efs-internal-file-readable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?r (list (aref modes 1) (aref modes 4) + (aref modes 7))) + (memq ?r (list (aref modes 4) (aref modes 7)))))) + t)) ; guess + +(defun efs-file-executable-p (file) + ;; Version of file-executable-p for remote files. + (let ((ent (efs-get-file-entry file))) + (and ent + (or (not (stringp (car ent))) + (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) + ;; file exists + (let* ((parsed (efs-ftp-path file)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-executable-p host-type user owner modes))))) + +(efs-defun efs-internal-file-executable-p nil (user owner modes) + ;; Guess t by default + t) + +(efs-defun efs-internal-file-executable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?x (list (aref modes 3) (aref modes 6) + (aref modes 9))) + (memq ?x (list (aref modes 6) (aref modes 9)))))) + t)) ; guess + +(defun efs-file-accessible-directory-p (dir) + ;; Version of file-accessible-directory-p for remote directories. + (let ((file (directory-file-name dir))) + (and (efs-file-directory-p file) (efs-file-executable-p file)))) + +;;;; -------------------------------------------------------------- +;;;; Listing directories. +;;;; -------------------------------------------------------------- + +(defun efs-shell-regexp-to-regexp (regexp) + ;; Converts a shell regexp to an emacs regexp. + ;; Probably full of bugs. Tries to follow csh globbing. + (let ((curly 0) + backslash) + (concat "^" + (mapconcat + (function + (lambda (char) + (cond + (backslash + (setq backslash nil) + (regexp-quote (char-to-string char))) + ((and (> curly 0) (eq char ?,)) + "\\|") + ((memq char '(?[ ?])) + (char-to-string char)) + ((eq char ??) + ".") + ((eq char ?\\) + (setq backslash t) + "") + ((eq char ?*) + ".*") + ((eq char ?{) + (setq curly (1+ curly)) + "\\(") + ((and (eq char ?}) (> curly 0)) + (setq curly (1- curly)) + "\\)") + (t (regexp-quote (char-to-string char)))))) + regexp nil) + "$"))) + + +;;; Getting directory listings. + +(defun efs-directory-files (directory &optional full match nosort) + ;; Returns directory-files for remote directories. + ;; NOSORT is a V19 arg. + (let* ((directory (expand-file-name directory)) + (parsed (efs-ftp-path directory)) + (directory (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) directory)) + files) + (efs-barf-if-not-directory directory) + (setq files (efs-hash-table-keys (efs-get-files directory) nosort)) + (cond + ((null (or full match)) + files) + (match ; this is slow case + (let (res f) + (efs-save-match-data + (while files + (setq f (if full (concat directory (car files)) (car files)) + files (cdr files)) + (if (string-match match f) + (setq res (nconc res (list f)))))) + res)) + (full + (mapcar (function + (lambda (fn) + (concat directory fn))) + files))))) + +(defun efs-list-directory (dirname &optional verbose) + ;; Version of list-directory for remote directories. + ;; If verbose is nil, it gets its information from efs's + ;; internal cache. + (let* ((dirname (expand-file-name (or dirname default-directory))) + header) + (if (file-directory-p dirname) + (setq dirname (file-name-as-directory dirname))) + (setq header dirname) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (princ "Directory ") + (princ header) + (terpri) + (princ + (efs-ls dirname (if verbose + list-directory-verbose-switches + list-directory-brief-switches) + t))))) + +;;;; ------------------------------------------------------------------- +;;;; Manipulating buffers. +;;;; ------------------------------------------------------------------- + +(defun efs-get-file-buffer (file) + ;; Version of get-file-buffer for remote files. Needs to fuss over things + ;; like OS's which are case-insens. for file names. + (let ((file (efs-canonize-file-name (expand-file-name file))) + (buff-list (buffer-list)) + buff-name) + (catch 'match + (while buff-list + (and (setq buff-name (buffer-file-name (car buff-list))) + (= (length buff-name) (length file)) ; efficiency hack + (string-equal (efs-canonize-file-name buff-name) file) + (throw 'match (car buff-list))) + (setq buff-list (cdr buff-list)))))) + +(defun efs-create-file-buffer (filename) + ;; Version of create-file-buffer for remote file names. + (let* ((parsed (efs-ftp-path (expand-file-name filename))) + (file (nth 2 parsed)) + (host (car parsed)) + (host-type (efs-host-type host)) + (buff (cond + ((null efs-fancy-buffer-names) + (if (string-equal file "/") + "/" + (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name file)))) + ((stringp efs-fancy-buffer-names) + (format efs-fancy-buffer-names + (if (string-equal file "/") + "/" + (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name file))) + (substring host 0 (string-match "\\." host 1)))) + (t ; efs-fancy-buffer-names had better be a function + (funcall efs-fancy-buffer-names host + (nth 1 parsed) file))))) + (if (memq host-type efs-case-insensitive-host-types) + (cond ((eq efs-buffer-name-case 'down) + (setq buff (downcase buff))) + ((eq efs-buffer-name-case 'up) + (setq buff (upcase buff))))) + (get-buffer-create (generate-new-buffer-name buff)))) + +(defun efs-set-buffer-mode () + "Set correct modes for the current buffer if it is visiting a remote file." + (if (and (stringp buffer-file-name) + (efs-ftp-path buffer-file-name)) + (progn + (auto-save-mode efs-auto-save) + (set (make-local-variable 'revert-buffer-function) + 'efs-revert-buffer) + (set (make-local-variable 'default-directory-function) + 'efs-default-dir-function)))) + +;;;; --------------------------------------------------------- +;;;; Functions for doing backups. +;;;; --------------------------------------------------------- + +(defun efs-backup-buffer () + ;; Version of backup-buffer for buffers visiting remote files. + (if efs-make-backup-files + (let* ((parsed (efs-ftp-path buffer-file-name)) + (host (car parsed)) + (host-type (efs-host-type (car parsed)))) + (if (or (not (listp efs-make-backup-files)) + (memq host-type efs-make-backup-files)) + (efs-internal-backup-buffer + host host-type (nth 1 parsed) (nth 2 parsed)))))) + +(defun efs-internal-backup-buffer (host host-type user remote-path) + ;; This is almost a copy of the function in files.el, modified + ;; to check to see if the backup file exists, before deleting it. + ;; It also supports efs-backup-by-copying, and tries to do the + ;; right thing about backup-by-copying-when-mismatch. Only called + ;; for remote files. + ;; Set the umask now, so that `setmodes' knows about it. + (efs-set-umask host user) + (let ((ent (efs-get-file-entry (expand-file-name buffer-file-name))) + ;; Never do version-control if the remote operating system is doing it. + (version-control (if (memq host-type efs-version-host-types) + 'never + version-control)) + modstring) + (and make-backup-files + (not buffer-backed-up) + ent ; i.e. file-exists-p + (not (eq t (car ent))) + (or (null (setq modstring (nth 3 ent))) + (not (memq host-type efs-unix-host-types)) + (memq (aref modstring 0) '(?- ?l))) + (or (< (length remote-path) 5) + (not (string-equal "/tmp/" (substring remote-path 0 5)))) + (condition-case () + (let* ((backup-info (find-backup-file-name buffer-file-name)) + (backupname (car backup-info)) + (targets (cdr backup-info)) + (links (nth 4 ent)) + setmodes) + (condition-case () + (if (or file-precious-flag + (stringp (car ent)) ; symlinkp + efs-backup-by-copying + (and backup-by-copying-when-linked + links (> links 1)) + (and backup-by-copying-when-mismatch + (not + (if (memq + host-type + efs-case-insensitive-host-types) + (string-equal + (downcase user) (downcase (nth 2 ent))) + (string-equal user (nth 2 ent)))))) + (copy-file buffer-file-name backupname t t) + (condition-case () + (if (file-exists-p backupname) + (delete-file backupname)) + (file-error nil)) + (rename-file buffer-file-name backupname t) + (setq setmodes (file-modes backupname))) + (file-error + ;; If trouble writing the backup, write it in ~. + (setq backupname (expand-file-name "~/%backup%~")) + (message + "Cannot write backup file; backing up in ~/%%backup%%~") + (sleep-for 1) + (copy-file buffer-file-name backupname t t))) + (setq buffer-backed-up t) + ;; Starting with 19.26, trim-versions-without-asking + ;; has been renamed to delete-old-verions. + (if (and targets + (or (if (boundp 'trim-versions-without-asking) + trim-versions-without-asking + (and + (boundp 'delete-old-versions) + delete-old-versions)) + (y-or-n-p (format + "Delete excess backup versions of %s? " + buffer-file-name)))) + (while targets + (condition-case () + (delete-file (car targets)) + (file-error nil)) + (setq targets (cdr targets)))) + ;; If the file was already written with the right modes, + ;; don't return set-modes. + (and setmodes + (null + (let ((buff (get-buffer + (efs-ftp-process-buffer host user)))) + (and buff + (save-excursion + (set-buffer buff) + (and (integerp efs-process-umask) + (= (efs-modes-from-umask efs-process-umask) + setmodes)))))) + setmodes)) + (file-error nil))))) + +;;;; ------------------------------------------------------------ +;;;; Redefinition for Emacs file mode support +;;;; ------------------------------------------------------------ + +(defmacro efs-build-mode-string-element (int suid-p sticky-p) + ;; INT is between 0 and 7. + ;; If SUID-P is non-nil, we are building the 3-char string for either + ;; the owner or group, and the s[ug]id bit is set. + ;; If STICKY-P is non-nil, we are building the string for other perms, + ;; and the sticky bit is set. + ;; It doesn't make sense for both SUID-P and STICKY-P be non-nil! + (` (let* ((int (, int)) + (suid-p (, suid-p)) + (sticky-p (, sticky-p)) + (read-bit (if (memq int '(4 5 6 7)) "r" "-")) + (write-bit (if (memq int '(2 3 6 7)) "w" "-")) + (x-bit (if (memq int '(1 3 5 7)) + (cond (suid-p "s") (sticky-p "t") ("x")) + (cond (suid-p "S") (sticky-p "T") ("-"))))) + (concat read-bit write-bit x-bit)))) + +(defun efs-mode-string (int) + ;; Takes an octal integer between 0 and 7777, and returns the 9 character + ;; mode string. + (let* ((other-int (% int 10)) + (int (/ int 10)) + (group-int (% int 10)) + (int (/ int 10)) + (owner-int (% int 10)) + (int (/ int 10)) + (suid (memq int '(4 5 6 7))) + (sgid (memq int '(2 3 6 7))) + (sticky (memq int '(1 3 5 7)))) + (concat (efs-build-mode-string-element owner-int suid nil) + (efs-build-mode-string-element group-int sgid nil) + (efs-build-mode-string-element other-int nil sticky)))) + +(defun efs-set-file-modes (file mode) + ;; set-file-modes for remote files. + ;; For remote files, if mode is nil, does nothing. + ;; This is because efs-file-modes returns nil if the modes + ;; of a remote file couldn't be determined, even if the file exists. + (and mode + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (r-file (nth 2 parsed)) + ;; convert to octal, and keep only 12 lowest order bits. + (omode (format "%o" (- mode (lsh (lsh mode -12) 12))))) + (if (or (efs-get-host-property host 'chmod-failed) + (null (memq (efs-host-type host user) efs-unix-host-types))) + (message "Unable to set file modes for %s to %s." file omode) + (efs-send-cmd + host user + (list 'quote 'site 'chmod omode r-file) + nil nil + (efs-cont (result line cont-lines) (host file r-file omode) + (if result + (progn + (efs-set-host-property host 'chmod-failed t) + (message "CHMOD %s failed for %s on %s." omode r-file host) + (if efs-ding-on-chmod-failure + (progn (ding) (sit-for 1)))) + (let ((ent (efs-get-file-entry file))) + (if ent + (let* ((type + (cond + ((null (car ent)) "-") + ((eq (car ent) t) "d") + ((stringp (car ent)) "s") + (t + (error + "Weird error in efs-set-file-modes")))) + (mode-string (concat + type + (efs-mode-string + (string-to-int omode)))) + (tail (nthcdr 3 ent))) + (if (consp tail) + (setcar tail mode-string) + (efs-add-file-entry nil file (car ent) (nth 1 ent) + (nth 2 ent) mode-string))))))) + 0)))) ; It should be safe to do this NOWAIT = 0 + ;; set-file-modes returns nil + nil) + +(defmacro efs-parse-mode-element (modes) + ;; Parses MODES, a string of three chars, and returns an integer + ;; between 0 and 7 according to how unix file modes are represented + ;; for chmod. + (` (if (= (length (, modes)) 3) + (let ((list (mapcar + (function (lambda (char) + (if (memq char '( ?- ?S ?T)) 0 1))) + (, modes)))) + ;; Convert to octal + (+ (* (car list) 4) (* (nth 1 list) 2) (nth 2 list))) + (error "Can't parse modes %s" (, modes))))) + +(defun efs-parse-mode-string (string) + ;; Parse a 9-character mode string, and return what it represents + ;; as a decimal integer. + (let ((owner (efs-parse-mode-element (substring string 0 3))) + (group (efs-parse-mode-element (substring string 3 6))) + (other (efs-parse-mode-element (substring string 6 9))) + (owner-x (elt string 2)) + (group-x (elt string 5)) + (other-x (elt string 8))) + (+ (* (+ (if (memq owner-x '(?s ?S)) 4 0) + (if (memq group-x '(?s ?S)) 2 0) + (if (memq other-x '(?t ?T)) 1 0)) + 512) + (* owner 64) + (* group 8) + other))) + +(defun efs-file-modes (file) + ;; Version of file-modes for remote files. + ;; Returns nil if the file modes can't be determined, either because + ;; the file doesn't exist, or for any other reason. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file))) + (and (memq (efs-host-type (car parsed)) efs-unix-host-types) + ;; Someday we should cache mode strings for non-unix, but they + ;; won't be in unix format. Also, CHMOD doesn't work for non-unix + ;; hosts, so returning this info to emacs is a waste. + (let* ((ent (efs-get-file-entry file)) + (modes (nth 3 ent))) + (and modes + (efs-parse-mode-string (substring modes 1))))))) + +;;;; ------------------------------------------------------------ +;;;; Redefinition of Emacs file modtime support. +;;;; ------------------------------------------------------------ + +(defun efs-day-number (year month day) + ;; Returns the day number within year of date. Taken from calendar.el, + ;; by Edward Reingold. Thanks. + ;; An explanation of the calculation can be found in PascAlgorithms by + ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. + (let ((day-of-year (+ day (* 31 (1- month))))) + (if (> month 2) + (progn + (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) + (if (zerop (% year 4)) + (setq day-of-year (1+ day-of-year))))) + day-of-year)) + +(defun efs-days-elapsed (year month day) + ;; Number of days elapsed since Jan 1, `efs-time-zero' + (+ (efs-day-number year month day) ; days this year + (* 365 (- year efs-time-zero)) ; days in prior years + (- (/ (max (1- year) efs-time-zero) 4) + (/ efs-time-zero 4)) ; leap years + -1 )) ; don't count today + +;; 2^16 = 65536 +;; Use this to avoid overflows + +(defun efs-seconds-elapsed (year month day hours minutes seconds) + ;; Computes the seconds elapsed from `efs-time-zero', in emacs' + ;; format of a list of two integers, the first the higher 16-bits, + ;; the second the lower 16-bits. + (let* ((days (efs-days-elapsed year month day)) + ;; compute hours + (hours (+ (* 24 days) hours)) + (high (lsh hours -16)) + (low (- hours (lsh high 16))) + ;; compute minutes + (low (+ (* low 60) minutes)) + (carry (lsh low -16)) + (high (+ (* high 60) carry)) + (low (- low (lsh carry 16))) + ;; compute seconds + (low (+ (* low 60) seconds)) + (carry (lsh low -16)) + (high (+ (* high 60) carry)) + (low (- low (lsh carry 16)))) + (list high low))) + +(defun efs-parse-mdtime (string) + ;; Parse a string, which is assumed to be the result of an ftp MDTM command. + (efs-save-match-data + (if (string-match efs-mdtm-msgs string) + (efs-seconds-elapsed + (string-to-int (substring string 4 8)) + (string-to-int (substring string 8 10)) + (string-to-int (substring string 10 12)) + (string-to-int (substring string 12 14)) + (string-to-int (substring string 14 16)) + (string-to-int (substring string 16 18)))))) + +(defun efs-parse-ctime (string) + ;; Parse STRING which is assumed to be the result of a query over port 37. + ;; Returns the number of seconds since the turn of the century, as a + ;; list of two 16-bit integers. + (and (= (length string) 4) + (list (+ (lsh (aref string 0) 8) (aref string 1)) + (+ (lsh (aref string 2) 8) (aref string 3))))) + +(defun efs-time-minus (time1 time2) + ;; Subtract 32-bit integers, represented as two 16-bit integers. + (let ((high (- (car time1) (car time2))) + (low (- (nth 1 time1) (nth 1 time2)))) + (cond + ((and (< high 0) (> low 0)) + (setq high (1+ high) + low (- low 65536))) + ((and (> high 0) (< low 0)) + (setq high (1- high) + low (+ 65536 low)))) + (list high low))) + +(defun efs-time-greater (time1 time2) + ;; Compare two 32-bit integers, each represented as a list of two 16-bit + ;; integers. + (or (> (car time1) (car time2)) + (and (= (car time1) (car time2)) + (> (nth 1 time1) (nth 1 time2))))) + +(defun efs-century-time (host &optional nowait cont) + ;; Treat nil as the local host. + ;; Returns the # of seconds since the turn of the century, according + ;; to the system clock on host. + ;; CONT is called with first arg HOST and second the # of seconds. + (or host (setq host (system-name))) + (efs-set-host-property host 'last-ctime nil) + (efs-set-host-property host 'ctime-cont cont) + (let ((name (format efs-ctime-process-name-format host)) + proc) + (condition-case nil (delete-process name) (error nil)) + (if (and + (or (efs-save-match-data (string-match efs-local-host-regexp host)) + (string-equal host (system-name))) + (setq proc (condition-case nil + (open-network-stream name nil host 37) + (error nil)))) + (progn + (set (intern name) "") + (set-process-filter + proc + (function + (lambda (proc string) + (let ((name (process-name proc)) + result) + (set (intern name) (concat (symbol-value (intern name)) + string)) + (setq result (efs-parse-ctime + (symbol-value (intern name)))) + (if result + (let* ((host (substring name 11 -1)) + (cont (efs-get-host-property host 'ctime-cont))) + (efs-set-host-property host 'last-ctime result) + (condition-case nil (delete-process proc) (error nil)) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host result))))))))) + (set-process-sentinel + proc + (function + (lambda (proc state) + (let* ((name (process-name proc)) + (host (substring name 11 -1)) + (cont (efs-get-host-property host 'ctime-cont))) + (makunbound (intern name)) + (or (efs-get-host-property host 'last-ctime) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host 'failed)))))))) + (if nowait + nil + (let ((quit-flag nil) + (inhibit-quit nil)) + (while (memq (process-status proc) '(run open)) + (accept-process-output))) + (accept-process-output) + (or (efs-get-host-property host 'last-ctime) + 'failed))) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host 'failed))) + (if nowait nil 'failed)))) + +(defun efs-clock-difference (host &optional nowait) + ;; clock difference with the local host + (let ((result (efs-get-host-property host 'clock-diff))) + (or + result + (progn + (efs-century-time + host nowait + (efs-cont (host result) (nowait) + (if (eq result 'failed) + (efs-set-host-property host 'clock-diff 'failed) + (efs-century-time + nil nowait + (efs-cont (lhost lresult) (host result) + (if (eq lresult 'failed) + (efs-set-host-property host 'clock-diff 'failed) + (efs-set-host-property host 'clock-diff + (efs-time-minus result lresult)))))))) + (and (null nowait) + (or (efs-get-host-property host 'clock-diff) + 'failed)))))) + +(defun efs-get-file-mdtm (host user file path) + "For HOST and USER, return FILE's last modification time. +PATH is the file name in full efs syntax. +Returns a list of two six-digit integers which represent the 16 high order +bits, and 16 low order bits of the number of elapsed seconds since +`efs-time-zero'" + (and (null (efs-get-host-property host 'mdtm-failed)) + (let ((result (efs-send-cmd host user (list 'quote 'mdtm file) + (and (eq efs-verbose t) + "Getting modtime"))) + parsed) + (if (and (null (car result)) + (setq parsed (efs-parse-mdtime (nth 1 result)))) + (let ((ent (efs-get-file-entry path))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) + parsed))) + parsed) + (efs-save-match-data + ;; The 550 error is for a nonexistent file. Actually implies + ;; that MDTM works. + (if (string-match "^550 " (nth 1 result)) + '(0 0) + (efs-set-host-property host 'mdtm-failed t) + nil)))))) + +(efs-define-fun efs-set-emacs-bvf-mdtm (buffer mdtm) + ;; Sets cached value for the buffer visited file modtime. + (if (get-buffer buffer) + (save-excursion + (set-buffer buffer) + (let (file-name-handler-alist) + (set-visited-file-modtime mdtm))))) + +;; (defun efs-set-visited-file-modtime (&optional time) +;; ;; For remote files sets the modtime for a buffer to be that of the +;; ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list +;; ;; of two 16-bit integers. +;; ;; The function set-visited-file-modtime is for emacs-19. It doesn't +;; ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for +;; ;; remote files only. +;; (if time +;; (efs-set-emacs-bvf-mdtm (current-buffer) time) +;; (let* ((path buffer-file-name) +;; (parsed (efs-ftp-path path)) +;; (host (car parsed)) +;; (user (nth 1 parsed)) +;; (file (nth 2 parsed)) +;; (buffer (current-buffer))) +;; (if (efs-save-match-data +;; (and efs-verify-modtime-host-regexp +;; (string-match efs-verify-modtime-host-regexp host) +;; (or efs-verify-anonymous-modtime +;; (not (efs-anonymous-p user))) +;; (not (efs-get-host-property host 'mdtm-failed)))) +;; (efs-send-cmd +;; host user (list 'quote 'mdtm file) +;; nil nil +;; (efs-cont (result line cont-lines) (host user path buffer) +;; (let (modtime) +;; (if (and (null result) +;; (setq modtime (efs-parse-mdtime line))) +;; (let ((ent (efs-get-file-entry path))) +;; (if ent +;; (setcdr ent (list (nth 1 ent) (nth 2 ent) +;; (nth 3 ent) (nth 4 ent) +;; modtime))) +;; (setq buffer (and (setq buffer (get-buffer buffer)) +;; (buffer-name buffer))) +;; ;; Beware that since this is happening asynch, the buffer +;; ;; may have disappeared. +;; (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) +;; (efs-save-match-data +;; (or (string-match "^550 " line) +;; (efs-set-host-property host 'mdtm-failed t))) +;; (efs-set-emacs-bvf-mdtm buffer 0)))) ; store dummy values +;; 0) ; Always do this NOWAIT = 0 +;; (efs-set-emacs-bvf-mdtm buffer 0)) +;; nil) ; return NIL +;; )) + +(defvar efs-set-modtimes-synchronously nil + "*Whether efs uses a synchronous FTP command to set the visited file modtime. +Setting this variable to non-nil means that efs will set visited file modtimes +synchronously. + +Asynchronous setting of visited file modtimes leaves a very small +window where Emacs may fail to detect a super session. However, it gives +faster user access to newly visited files.") + + +(defun efs-set-visited-file-modtime (&optional time) + ;; For remote files sets the modtime for a buffer to be that of the + ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list + ;; of two 16-bit integers. + ;; The function set-visited-file-modtime is for emacs-19. It doesn't + ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for + ;; remote files only. + (if time + (efs-set-emacs-bvf-mdtm (current-buffer) time) + (let* ((path buffer-file-name) + (parsed (efs-ftp-path path)) + (host (car parsed)) + (user (nth 1 parsed)) + (file (nth 2 parsed)) + (buffer (current-buffer))) + (if (efs-save-match-data + (and efs-verify-modtime-host-regexp + (string-match efs-verify-modtime-host-regexp host) + (or efs-verify-anonymous-modtime + (not (efs-anonymous-p user))) + (not (efs-get-host-property host 'mdtm-failed)))) + (progn + (or efs-set-modtimes-synchronously (clear-visited-file-modtime)) + (efs-send-cmd + host user (list 'quote 'mdtm file) + nil nil + (efs-cont (result line cont-lines) (host user path buffer) + (let (modtime) + (if (and (null result) + (setq modtime (efs-parse-mdtime line))) + (let ((ent (efs-get-file-entry path))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) + modtime))) + (setq buffer (and (setq buffer (get-buffer buffer)) + (buffer-name buffer))) + ;; Beware that since might be happening asynch, + ;; the buffer may have disappeared. + (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) + (efs-save-match-data + (or (string-match "^550 " line) + (efs-set-host-property host 'mdtm-failed t))) + (efs-set-emacs-bvf-mdtm buffer '(0 0))))) ; store dummy values + (and (null efs-set-modtimes-synchronously) 0))) + (efs-set-emacs-bvf-mdtm buffer '(0 0))) + nil))) ; return NIL + +(defun efs-file-newer-than-file-p (file1 file2) + ;; Version of file-newer-than-file-p for remote files. + (let* ((file1 (expand-file-name file1)) + (file2 (expand-file-name file2)) + (parsed1 (efs-ftp-path file1)) + (parsed2 (efs-ftp-path file2)) + (host1 (car parsed1)) + (host2 (car parsed2)) + (user1 (nth 1 parsed1)) + (user2 (nth 1 parsed2))) + (cond + ;; If the first file doedn't exist, or is remote but + ;; we're not supposed to check modtimes on it, return nil. + ((or (null (file-exists-p file1)) + (and parsed1 + (or + (null efs-verify-modtime-host-regexp) + (efs-get-host-property host1 'mdtm-failed) + (not (string-match efs-verify-modtime-host-regexp host1)) + (and (null efs-verify-anonymous-modtime) + (efs-anonymous-p user1))))) + nil) + ;; If the same is true for the second file, return t. + ((or (null (file-exists-p file2)) + (and parsed2 + (or + (null efs-verify-modtime-host-regexp) + (efs-get-host-property host2 'mdtm-failed) + (not (string-match efs-verify-modtime-host-regexp host2)) + (and (null efs-verify-anonymous-modtime) + (efs-anonymous-p user2))))) + t) + ;; Calculate modtimes. If we get here, any remote files should + ;; have a file entry. + (t + (let (mod1 mod2 shift1 shift2) + (if parsed1 + (let ((ent (efs-get-file-entry file1))) + (setq mod1 (nth 5 ent) + shift1 (efs-clock-difference host1)) + (or mod1 + (setq mod1 (efs-get-file-mdtm + host1 user1 (nth 2 parsed1) file1)))) + (setq mod1 (nth 5 (file-attributes file1)))) + (if parsed2 + (let ((ent (efs-get-file-entry file2))) + (setq mod2 (nth 5 ent) + shift2 (efs-clock-difference host2)) + (or mod2 + (setq mod2 (efs-get-file-mdtm + host2 user2 (nth 2 parsed2) file2)))) + (setq mod2 (nth 5 (file-attributes file2)))) + ;; If we can't compute clock shifts, we act as if we don't + ;; even know the modtime. Should we have more faith in ntp? + (cond + ((or (null mod1) (eq shift1 'failed)) + nil) + ((or (null mod2) (eq shift2 'failed)) + t) + ;; We get to compute something! + (t + (efs-time-greater + (if shift1 (efs-time-minus mod1 shift1) mod1) + (if shift2 (efs-time-minus mod2 shift2) mod2))))))))) + +(defun efs-verify-visited-file-modtime (buff) + ;; Verifies the modtime for buffers visiting remote files. + ;; Won't get called for buffer not visiting any file. + (let ((buff (get-buffer buff))) + (null + (and buff ; return t if no buffer? Need to beware of multi-threading. + (buffer-file-name buff) ; t if no file + (let ((mdtm (save-excursion + (set-buffer buff) + (visited-file-modtime)))) + (and + (not (eq mdtm 0)) + (not (equal mdtm '(0 0))) + efs-verify-modtime-host-regexp + (let* ((path (buffer-file-name buff)) + (parsed (efs-ftp-path path)) + (host (car parsed)) + (user (nth 1 parsed)) + nmdtm) + (and + (null (efs-get-host-property host 'mdtm-failed)) + (efs-save-match-data + (string-match + efs-verify-modtime-host-regexp host)) + (or efs-verify-anonymous-modtime + (not (efs-anonymous-p user))) + (setq nmdtm (efs-get-file-mdtm host user (nth 2 parsed) path)) + (progn + (or (equal nmdtm '(0 0)) + (file-exists-p path) ; Make sure that there is an entry. + (null + (efs-get-files + (file-name-directory + (efs-internal-directory-file-name path)))) + (efs-add-file-entry + (efs-host-type host) path nil nil nil nil nil nmdtm)) + (null (and (eq (cdr mdtm) (nth 1 nmdtm)) + (eq (car mdtm) (car nmdtm))))))))))))) + +;;;; ----------------------------------------------------------- +;;;; Redefinition of Emacs file name completion +;;;; ----------------------------------------------------------- + +(defmacro efs-set-completion-ignored-pattern () + ;; Set regexp efs-completion-ignored-pattern + ;; to use for filename completion. + (` + (or (equal efs-completion-ignored-extensions + completion-ignored-extensions) + (setq efs-completion-ignored-extensions + completion-ignored-extensions + efs-completion-ignored-pattern + (mapconcat (function + (lambda (s) (if (stringp s) + (concat (regexp-quote s) "$") + "/"))) ; / never in filename + efs-completion-ignored-extensions + "\\|"))))) + +(defun efs-file-entry-active-p (sym) + ;; If the file entry is a symlink, returns whether the file pointed to + ;; exists. + ;; Note that DIR is dynamically bound. + (let ((file-type (car (get sym 'val)))) + (or (not (stringp file-type)) + (file-exists-p (efs-chase-symlinks + (expand-file-name file-type efs-completion-dir)))))) + +(defun efs-file-entry-not-ignored-p (sym) + ;; If the file entry is not a directory (nor a symlink pointing to a + ;; directory) returns whether the file (or file pointed to by the symlink) + ;; is ignored by completion-ignored-extensions. + (let ((file-type (car (get sym 'val))) + (symname (symbol-name sym))) + (if (stringp file-type) + ;; Maybe file-truename would be better here, but it is very costly + ;; to chase symlinks at every level over FTP. + (let ((file (efs-chase-symlinks (expand-file-name + file-type efs-completion-dir)))) + (or (file-directory-p file) + (and (file-exists-p file) + (not (string-match efs-completion-ignored-pattern + symname))))) + (or file-type ; is a directory name + (not (string-match efs-completion-ignored-pattern symname)))))) + +(defun efs-file-name-all-completions (file dir) + ;; Does file-name-all-completions in remote directories. + (efs-barf-if-not-directory dir) + (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) + (completion-ignore-case + (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) + efs-case-insensitive-host-types)) + (tbl (efs-get-files efs-completion-dir)) + (completions + (all-completions file tbl + (function efs-file-entry-active-p)))) + ;; see whether each matching file is a directory or not... + (mapcar + ;; Since the entries in completions will match the case + ;; of the entries in tbl, don't need to case-fold + ;; in efs-get-hash-entry below. + (function + (lambda (file) + (let ((ent (car (efs-get-hash-entry file tbl)))) + (if (or (eq ent t) + (and (stringp ent) + (file-directory-p (efs-chase-symlinks + (expand-file-name + ent efs-completion-dir))))) + (concat file "/") + file)))) + completions))) + +(defun efs-file-name-completion (file dir) + ;; Does file name expansion in remote directories. + (efs-barf-if-not-directory dir) + (if (equal file "") + "" + (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) + (completion-ignore-case + (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) + efs-case-insensitive-host-types)) + (tbl (efs-get-files efs-completion-dir))) + (efs-set-completion-ignored-pattern) + (efs-save-match-data + (or (efs-file-name-completion-1 + file tbl efs-completion-dir + (function efs-file-entry-not-ignored-p)) + (efs-file-name-completion-1 + file tbl efs-completion-dir + (function efs-file-entry-active-p))))))) + +(defun efs-file-name-completion-1 (file tbl dir predicate) + ;; Internal subroutine for efs-file-name-completion. Do not call this. + (let ((bestmatch (try-completion file tbl predicate))) + (if bestmatch + (if (eq bestmatch t) + (if (file-directory-p (expand-file-name file dir)) + (concat file "/") + t) + (if (and (eq (try-completion bestmatch tbl predicate) t) + (file-directory-p + (expand-file-name bestmatch dir))) + (concat bestmatch "/") + bestmatch))))) + +;;;; ---------------------------------------------------------- +;;;; Functions for loading lisp. +;;;; ---------------------------------------------------------- + +;;; jka-load provided ideas here. Thanks, Jay. + +(defun efs-load-openp (str suffixes) + ;; Given STR, searches load-path and efs-load-lisp-extensions + ;; for the name of a file to load. Returns the full path, or nil + ;; if none found. + (let ((path-list (if (file-name-absolute-p str) t load-path)) + root result) + ;; If there is no load-path, at least try the default directory. + (or path-list + (setq path-list (list default-directory))) + (while (and path-list (null result)) + (if (eq path-list t) + (setq path-list nil + root str) + (setq root (expand-file-name str (car path-list)) + path-list (cdr path-list)) + (or (file-name-absolute-p root) + (setq root (expand-file-name root default-directory)))) + (let ((suff-list suffixes)) + (while (and suff-list (null result)) + (let ((try (concat root (car suff-list)))) + (if (or (not (file-readable-p try)) + (file-directory-p try)) + (setq suff-list (cdr suff-list)) + (setq result try)))))) + result)) + +(defun efs-load (file &optional noerror nomessage nosuffix) + "Documented as original." + (let ((filename (efs-load-openp + file + (if nosuffix '("") efs-load-lisp-extensions)))) + (if (not filename) + (and (null noerror) (error "Cannot open load file %s" file)) + (let ((parsed (efs-ftp-path filename)) + (after-load (and (boundp 'after-load-alist) + (assoc file after-load-alist)))) + (if parsed + (let ((temp (car (efs-make-tmp-name nil (car parsed))))) + (unwind-protect + (progn + (efs-copy-file-internal + filename parsed temp nil t nil + (format "Getting %s" filename)) + (or (file-readable-p temp) + (error + "efs-load: temp file %s is unreadable" temp)) + (or nomessage + (message "Loading %s..." file)) + ;; temp is an absolute filename, so load path + ;; won't be searched. + (let (after-load-alist) + (efs-real-load temp t t t)) + (or nomessage + (message "Loading %s...done" file)) + (if after-load (mapcar 'eval (cdr after-load))) + t) ; return t if everything worked + (efs-del-tmp-name temp))) + (prog2 + (or nomessage + (message "Loading %s..." file)) + (let (after-load-alist) + (or (efs-real-load filename noerror t t) + (setq after-load nil))) + (or nomessage + (message "Loading %s...done" file)) + (if after-load (mapcar 'eval (cdr after-load))))))))) + +(defun efs-require (feature &optional filename) + "Documented as original." + (if (eq feature 'ange-ftp) (efs-require-scream-and-yell)) + (if (featurep feature) + feature + (or filename (setq filename (symbol-name feature))) + (let ((fullpath (efs-load-openp filename + efs-load-lisp-extensions))) + (if (not fullpath) + (error "Cannot open load file: %s" filename) + (let ((parsed (efs-ftp-path fullpath))) + (if parsed + (let ((temp (car (efs-make-tmp-name nil (car parsed))))) + (unwind-protect + (progn + (efs-copy-file-internal + fullpath parsed temp nil t nil + (format "Getting %s" fullpath)) + (or (file-readable-p temp) + (error + "efs-require: temp file %s is unreadable" temp)) + (efs-real-require feature temp)) + (efs-del-tmp-name temp))) + (efs-real-require feature fullpath))))))) + +(defun efs-require-scream-and-yell () + ;; Complain if something attempts to load ange-ftp. + (with-output-to-temp-buffer "*Help*" + (princ + "Something tried to load ange-ftp. +EFS AND ANGE-FTP DO NOT WORK TOGETHER. + +If the culprit package does need to access ange-ftp internal functions, +then it should be adequate to simply remove the \(require 'ange-ftp\) +line and let efs handle remote file access. Otherwise, it will need to +be ported to efs. This may already have been done, and you can find out +by sending an enquiry to efs-help@cuckoo.hpl.hp.com. + +Signalling an error with backtrace will allow you to determine which +package was requiring ange-ftp.\n")) + (select-window (get-buffer-window "*Help*")) + (enlarge-window (- (count-lines (point-min) (point-max)) + (window-height) -1)) + (if (y-or-n-p "Signal error with backtrace? ") + (let ((stack-trace-on-error t)) + (error "Attempt to require ange-ftp")))) + +;;;; ----------------------------------------------------------- +;;;; Redefinition of Emacs functions for reading file names. +;;;; ----------------------------------------------------------- + +(defun efs-unexpand-parsed-filename (host user path) + ;; Replaces the home directory in path with "~". Returns the unexpanded + ;; full-path. + (let* ((path-len (length path)) + (def-user (efs-get-user host)) + (host-type (efs-host-type host user)) + (ignore-case (memq host-type efs-case-insensitive-host-types))) + (if (> path-len 1) + (let* ((home (efs-expand-tilde "~" host-type host user)) + (home-len (length home))) + (if (and (> path-len home-len) + (if ignore-case (string-equal (downcase home) + (downcase + (substring path + 0 home-len))) + (string-equal home (substring path 0 home-len))) + (= (aref path home-len) ?/)) + (setq path (concat "~" (substring path home-len)))))) + (if (if ignore-case (string-equal (downcase user) + (downcase def-user)) + (string-equal user def-user)) + (format efs-path-format-without-user host path) + (format efs-path-format-string user host path)))) + +(efs-define-fun efs-abbreviate-file-name (filename) + ;; Version of abbreviate-file-name for remote files. + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) filename) + (setq filename + (concat (cdr (car tail)) + (substring filename (match-end 0))))) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename (efs-ftp-path filename))))) + +(defun efs-default-dir-function () + (let ((parsed (efs-ftp-path default-directory)) + (dd default-directory)) + (if parsed + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) dd) + (setq dd (concat (cdr (car tail)) + (substring dd (match-end 0))) + parsed nil)) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename + (or parsed (efs-ftp-path dd))))) + default-directory))) + +(defun efs-re-read-dir (&optional dir) + "Forces a re-read of the directory DIR. +If DIR is omitted then it defaults to the directory part of the contents +of the current buffer. This is so this function can be caled from the +minibuffer." + (interactive) + (if dir + (setq dir (expand-file-name dir)) + (setq dir (file-name-directory (expand-file-name (buffer-string))))) + (let ((parsed (efs-ftp-path dir))) + (if parsed + (let ((efs-ls-uncache t)) + (efs-del-hash-entry (efs-canonize-file-name dir) + efs-files-hashtable) + (efs-get-files dir t))))) + +;;;; --------------------------------------------------------------- +;;;; Creation and deletion of files and directories. +;;;; --------------------------------------------------------------- + +(defun efs-delete-file (file) + ;; Deletes remote files. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + (path (nth 2 parsed)) + (abbr (efs-relativize-filename file)) + (result (efs-send-cmd host user (list 'delete path) + (format "Deleting %s" abbr)))) + (if (car result) + (signal 'ftp-error + (list "Removing old name" + (format "FTP Error: \"%s\"" (nth 1 result)) + file))) + (efs-delete-file-entry host-type file))) + +(defun efs-make-directory-internal (dir) + ;; version of make-directory-internal for remote directories. + (if (file-exists-p dir) + (error "Cannot make directory %s: file already exists" dir) + (let* ((parsed (efs-ftp-path dir)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that mkdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that mkdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (path (if (or (memq host-type efs-unix-host-types) + (memq host-type '(os2 dos))) + (efs-internal-directory-file-name (nth 2 parsed)) + (efs-internal-file-name-as-directory + host-type (nth 2 parsed)))) + (abbr (efs-relativize-filename dir)) + (result (efs-send-cmd host user + (list 'mkdir path) + (format "Making directory %s" + abbr)))) + (if (car result) + (efs-error host user + (format "Could not make directory %s: %s" dir + (nth 1 result)))) + (efs-add-file-entry host-type dir t nil user)))) + +;; V19 calls this function delete-directory. It used to be called +;; remove-directory. + +(defun efs-delete-directory (dir) + ;; Version of delete-directory for remote directories. + (if (file-directory-p dir) + (let* ((parsed (efs-ftp-path dir)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that rmdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that rmdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (path + (if (or (memq host-type efs-unix-host-types) + (memq host-type '(os2 dos))) + (efs-internal-directory-file-name (nth 2 parsed)) + (efs-internal-file-name-as-directory + host-type (nth 2 parsed)))) + (abbr (efs-relativize-filename dir)) + (result (efs-send-cmd host user + (list 'rmdir path) + (format "Deleting directory %s" abbr)))) + (if (car result) + (efs-error host user + (format "Could not delete directory %s: %s" + dir (nth 1 result)))) + (efs-delete-file-entry host-type dir t)) + (error "Not a directory: %s" dir))) + +(defun efs-file-local-copy (file) + ;; internal function for diff.el (dired 6.3 or later) + ;; Makes a temp file containing the contents of file. + ;; returns the name of the tmp file created, or nil if none is. + ;; This function should have optional cont and nowait args. + (let* ((file (expand-file-name file)) + (tmp (car (efs-make-tmp-name nil (car (efs-ftp-path file)))))) + (efs-copy-file-internal file (efs-ftp-path file) + tmp nil t nil (format "Getting %s" file)) + tmp)) + +(defun efs-diff/grep-del-temp-file (temp) + ;; internal function for diff.el and grep.el + ;; if TEMP is non-nil, deletes the temp file TEMP. + ;; if TEMP is nil, does nothing. + (and temp + (efs-del-tmp-name temp))) + +;;;; ------------------------------------------------------------ +;;;; File copying support... +;;;; ------------------------------------------------------------ + +;;; - totally re-written 6/24/92. +;;; - re-written again 9/3/93 +;;; - and again 14/4/93 +;;; - and again 17/8/93 + +(defun efs-barf-or-query-if-file-exists (absname querystring interactive) + (if (file-exists-p absname) + (if (not interactive) + (signal 'file-already-exists (list absname)) + (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " + absname querystring))) + (signal 'file-already-exists (list absname)))))) + +(defun efs-concatenate-files (file1 file2) + ;; Concatenates file1 to file2. Both must be local files. + ;; Needed because the efs version of copy-file understands + ;; ok-if-already-exists = 'append + (or (file-readable-p file1) + (signal 'file-error + (list (format "Input file %s not readable." file1)))) + (or (file-writable-p file2) + (signal 'file-error + (list (format "Output file %s not writable." file2)))) + (let ((default-directory exec-directory)) + (call-process "sh" nil nil nil "-c" (format "cat %s >> %s" file1 file2)))) + +(defun efs-copy-add-file-entry (newname host-type user size append) + ;; Add an entry in `efs-files-hashtable' for a file newly created via a copy. + (if (eq size -1) (setq size nil)) + (if append + (let ((ent (efs-get-file-entry newname))) + (if (and ent (null (car ent))) + (if (and size (numberp (nth 1 ent))) + (setcar (cdr ent) (+ size (nth 1 ent))) + (setcar (cdr ent) nil)) + ;; If the ent is a symlink or directory, don't overwrite that entry. + (if (null ent) + (efs-add-file-entry host-type newname nil nil nil)))) + (efs-add-file-entry host-type newname nil size user))) + +(defun efs-copy-remote-to-remote (f-host-type f-host f-user f-path filename + t-host-type t-host t-user + t-path newname append msg cont + nowait xfer-type) +;; Use a 3rd data connection to copy from F-HOST for F-USER to T-HOST +;; for T-USER. + (if (efs-get-host-property t-host 'pasv-failed) + ;; PASV didn't work before, don't try again. + (if cont (efs-call-cont cont 'failed "" "")) + (or xfer-type + (setq xfer-type (efs-xfer-type f-host-type filename + t-host-type newname))) + (efs-send-cmd + t-host t-user '(quote pasv) nil nil + (efs-cont (pasv-result pasv-line pasv-cont-lines) + (cont nowait f-host-type f-host f-user f-path filename + t-host-type t-host t-user t-path newname xfer-type msg append) + (efs-save-match-data + (if (or pasv-result + (not (string-match efs-pasv-msgs pasv-line))) + (progn + (efs-set-host-property t-host 'pasv-failed t) + (if cont + (efs-call-cont + cont (or pasv-result 'failed) pasv-line pasv-cont-lines))) + (let ((address (substring pasv-line (match-beginning 1) + (match-end 1)))) + (efs-send-cmd + f-host f-user + (list 'quote 'port address) nil nil + (efs-cont (port-result port-line port-cont-lines) + (cont f-host f-user f-host-type f-path filename + xfer-type msg) + (if port-result + (if cont + (efs-call-cont + cont port-result port-line port-cont-lines) + (efs-error f-host f-user + (format "PORT failed for %s: %s" + filename port-line))) + (efs-send-cmd + f-host f-user + (list 'quote 'retr f-path xfer-type) + msg nil + (efs-cont (retr-result retr-line retr-cont-lines) + (cont f-host f-user f-path) + (and retr-result + (null cont) + (efs-error + f-host f-user + (format "RETR failed for %s: %s" + f-path retr-line))) + (if cont (efs-call-cont + cont retr-result retr-line retr-cont-lines))) + (if (eq nowait t) 1 nowait)))) + 1) ; can't ever wait on this command. + (efs-send-cmd + t-host t-user + (list 'quote (if append 'appe 'stor) t-path xfer-type) + nil nil + (efs-cont (stor-result stor-line stor-cont-lines) + (t-host t-user t-path t-host-type newname filename + append) + (if stor-result + (efs-error + t-host t-user (format "%s failed for %s: %s" + (if append "APPE" "STOR") + t-path stor-line)) + (efs-copy-add-file-entry + newname t-host-type t-user + (nth 1 (efs-get-file-entry filename)) append))) + (if (eq nowait t) 1 nowait)))))) + nowait))) + +(defun efs-copy-on-remote (host user host-type filename newname filename-parsed + newname-parsed keep-date append-p msg cont + nowait xfer-type) + ;; Uses site exec to copy the file on a remote host + (let ((exec-cp (efs-get-host-property host 'exec-cp))) + (if (or append-p + (not (memq host-type efs-unix-host-types)) + (efs-get-host-property host 'exec-failed) + (eq exec-cp 'failed)) + (efs-copy-via-temp filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if (eq exec-cp 'works) + (efs-send-cmd + host user + (list 'quote 'site 'exec + (format "cp %s%s %s" (if keep-date "-p " "") + (nth 2 filename-parsed) (nth 2 newname-parsed))) + msg nil + (efs-cont (result line cont-lines) (host user filename newname + host-type filename-parsed + newname-parsed + keep-date append-p msg cont + xfer-type nowait) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-copy-via-temp filename filename-parsed newname + newname-parsed append-p keep-date + nil cont nowait xfer-type)) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (efs-copy-add-file-entry + newname host-type user + (nth 7 (efs-file-attributes filename)) nil) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait) + (message "Checking for cp executable on %s..." host) + (efs-send-cmd + host user (list 'quote 'site 'exec "cp / /") nil nil + (efs-cont (result line cont-lines) (host user filename newname + host-type filename-parsed + newname-parsed + keep-date append-p msg cont + xfer-type nowait) + (efs-save-match-data + (if (string-match "\n200-" cont-lines) + (efs-set-host-property host 'exec-cp 'works) + (efs-set-host-property host 'exec-cp 'failed))) + (efs-copy-on-remote host user host-type filename newname + filename-parsed newname-parsed keep-date + append-p msg cont nowait xfer-type)) + nowait))))) + +(defun efs-copy-via-temp (filename filename-parsed newname newname-parsed + append keep-date msg cont nowait xfer-type) + ;; Copies from FILENAME to NEWNAME via a temp file. + (let* ((temp (car (if (efs-use-gateway-p (car filename-parsed) t) + (efs-make-tmp-name (car filename-parsed) + (car newname-parsed)) + (efs-make-tmp-name (car newname-parsed) + (car filename-parsed))))) + (temp-parsed (efs-ftp-path temp))) + (or xfer-type (setq xfer-type + (efs-xfer-type + (efs-host-type (car filename-parsed)) filename + (efs-host-type (car newname-parsed)) newname + t))) + (efs-copy-file-internal + filename filename-parsed temp temp-parsed t nil (if (eq 0 msg) 2 msg) + (efs-cont (result line cont-lines) (newname newname-parsed temp + temp-parsed append msg cont + nowait xfer-type) + (if result + (progn + (efs-del-tmp-name temp) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename)))) + (efs-copy-file-internal + temp temp-parsed newname newname-parsed (if append 'append t) nil + (if (eq msg 0) 1 msg) + (efs-cont (result line cont-lines) (temp newname cont) + (efs-del-tmp-name temp) + (if cont + (efs-call-cont cont result line cont-lines) + (if result + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\" " line) newname))))) + nowait xfer-type))) + nowait xfer-type))) + +(defun efs-copy-file-internal (filename filename-parsed newname newname-parsed + ok-if-already-exists keep-date + &optional msg cont nowait xfer-type) + ;; Internal function for copying a file from FILENAME to NEWNAME. + ;; FILENAME-PARSED and NEWNAME-PARSED are the lists obtained by parsing + ;; FILENAME and NEWNAME with efs-ftp-path. + ;; If OK-IF-ALREADY-EXISTS is nil, then existing files will not be + ;; overwritten. + ;; If it is a number, then the user will be prompted about overwriting. + ;; If it eq 'append, then an existing file will be appended to. + ;; If it has anyother value, then existing files will be silently + ;; overwritten. + ;; If KEEP-DATE is t then we will attempt to reatin the date of the + ;; original copy of the file. If this is a string, the modtime of the + ;; NEWNAME will be set to this date. Must be in touch -t format. + ;; If MSG is nil, then the copying will be done silently. + ;; If it is a string, then that will be the massage displayed while copying. + ;; If it is 0, then a suitable default message will be computed. + ;; If it is 1, then a suitable default will be computed, assuming + ;; that FILENAME is a temporary file, whose name is not suitable to use + ;; in a status message. + ;; If it is 2, then a suitable default will be used, assuming that + ;; NEWNAME is a temporary file. + ;; CONT is a continuation to call after completing the copy. + ;; The first two args are RESULT and LINE, the result symbol and status + ;; line of the FTP command. If more than one ftp command has been used, + ;; then these values for the last FTP command are given. + ;; NOWAIT can be either nil, 0, 1, t. See `efs-send-cmd' for an explanation. + ;; XFER-TYPE is the transfer type to use for transferring the files. + ;; If this is nil, than a suitable transfer type is computed. + ;; Does not call expand-file-name. Do that yourself. + + ;; check to see if we can overwrite + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "copy to it" (numberp ok-if-already-exists))) + (if (null (or filename-parsed newname-parsed)) + ;; local to local copy + (progn + (if (eq ok-if-already-exists 'append) + (efs-concatenate-files filename newname) + (copy-file filename newname ok-if-already-exists keep-date)) + (if cont + (efs-call-cont cont nil "Copied locally" ""))) + (let* ((f-host (car filename-parsed)) + (f-user (nth 1 filename-parsed)) + (f-path (nth 2 filename-parsed)) + (f-host-type (efs-host-type f-host f-user)) + (f-gate-p (efs-use-gateway-p f-host t)) + (t-host (car newname-parsed)) + (t-user (nth 1 newname-parsed)) + (t-path (nth 2 newname-parsed)) + (t-host-type (efs-host-type t-host t-user)) + (t-gate-p (efs-use-gateway-p t-host t)) + (append-p (eq ok-if-already-exists 'append)) + gatename) + + (if (and (eq keep-date t) (null newname-parsed)) + ;; f-host must be remote now. + (setq keep-date filename)) + + (cond + + ;; Check to see if we can do a PUT + ((or + (and (null f-host) + (or (null t-gate-p) + (setq gatename (efs-local-to-gateway-filename filename)))) + (and t-gate-p + f-host + (string-equal (downcase f-host) (downcase efs-gateway-host)) + (if (memq f-host-type efs-case-insensitive-host-types) + (string-equal (downcase f-user) + (downcase (efs-get-user efs-gateway-host))) + (string-equal f-user (efs-get-user efs-gateway-host))))) + (or f-host (let (file-name-handler-alist) + (if (file-exists-p filename) + (cond + ((file-directory-p filename) + (signal 'file-error + (list "Non-regular file" + "is a directory" filename))) + ((not (file-readable-p filename)) + (signal 'file-error + (list "Opening input file" + "permission denied" filename)))) + (signal 'file-error + (list "Opening input file" + "no such file or directory" filename))))) + (or xfer-type + (setq xfer-type + (efs-xfer-type f-host-type filename t-host-type newname))) + (let ((size (and (or (null f-host-type) + (efs-file-entry-p filename)) + (nth 7 (file-attributes filename))))) + ;; -1 is a bogus size for remote files + (if (eq size -1) (setq size nil)) + (efs-send-cmd + t-host t-user + (list (if append-p 'append 'put) + (if f-host + f-path + (or gatename filename)) + t-path + xfer-type) + (cond ((eq msg 2) + (concat (if append-p "Appending " "Putting ") + (efs-relativize-filename filename))) + ((eq msg 1) + (concat (if append-p "Appending " "Putting ") + (efs-relativize-filename newname))) + ((eq msg 0) + (concat (if append-p "Appending " "Copying ") + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + (t msg)) + (and size (list 'efs-set-xfer-size t-host t-user size)) + (efs-cont (result line cont-lines) (newname t-host-type t-user size + append-p cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\" " line) newname))) + ;; add file entry + (efs-copy-add-file-entry newname t-host-type t-user + size append-p) + (if cont + (efs-call-cont cont result line cont-lines)))) + nowait))) + + ;; Check to see if we can do a GET + ((and + ;; I think that giving the append arg, will cause this function + ;; to make a temp file, recursively call itself, and append the temp + ;; file to the local file. Hope it works out... + (null append-p) + (or + (and (null t-host) + (or (null f-gate-p) + (setq gatename (efs-local-to-gateway-filename newname)))) + (and f-gate-p + t-host + (string-equal (downcase t-host) (downcase efs-gateway-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) + (downcase (efs-get-user efs-gateway-host))) + (string-equal t-user (efs-get-user efs-gateway-host)))))) + (or t-host (let (file-name-handler-alist) + (cond ((not (file-writable-p newname)) + (signal 'file-error + (list "Opening output file" + "permission denied" newname))) + ((file-directory-p newname) + (signal 'file-error + (list "Opening output file" + "is a directory" newname)))))) + (or xfer-type + (setq xfer-type + (efs-xfer-type f-host-type filename t-host-type newname))) + (let ((size (and (or (null f-host-type) + (efs-file-entry-p filename)) + (nth 7 (file-attributes filename))))) + ;; -1 is a bogus size for remote files. + (if (eq size -1) (setq size nil)) + (efs-send-cmd + f-host f-user + (list 'get + f-path + (if t-host + t-path + (or gatename newname)) + xfer-type) + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 2) + (concat "Getting " (efs-relativize-filename filename))) + ((eq msg 1) + (concat "Getting " (efs-relativize-filename newname))) + (t msg)) + ;; If the server emits a efs-xfer-size-msgs, it will over-ride this. + ;; With no xfer msg, this is will do the job. + (and size (list 'efs-set-xfer-size f-host f-user size)) + (efs-cont (result line cont-lines) (filename newname size + t-host-type t-user + cont keep-date) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename))) + ;; Add a new file entry, if relevant. + (if t-host-type + ;; t-host will be equal to efs-gateway-host, if t-host-type + ;; is non-nil. + (efs-copy-add-file-entry newname t-host-type + t-user size nil)) + (if (and (null t-host-type) (stringp keep-date)) + (efs-set-mdtm-of + filename newname + (and cont + (efs-cont (result1 line1 cont-lines1) (result + line cont-lines + cont) + (efs-call-cont cont result line cont-lines)))) + (if cont + (efs-call-cont cont result line cont-lines))))) + nowait))) + + ;; Can we do a EXEC cp? + ((and t-host f-host + (string-equal (downcase t-host) (downcase f-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) (downcase f-user)) + (string-equal t-user f-user))) + (efs-copy-on-remote + t-host t-user t-host-type filename newname filename-parsed + newname-parsed keep-date append-p + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 1) + (concat "Copying " (efs-relativize-filename newname))) + ((eq msg 2) + (concat "Copying " (efs-relativize-filename filename))) + (t msg)) + cont nowait xfer-type)) + + ;; Try for a copy with PASV + ((and t-host f-host + (not (and (string-equal (downcase t-host) (downcase f-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) (downcase f-user)) + (string-equal t-user f-user)))) + (or + (and efs-gateway-host + ;; The gateway should be able to talk to anything. + (let ((gh (downcase efs-gateway-host))) + (or (string-equal (downcase t-host) gh) + (string-equal (downcase f-host) gh)))) + (efs-save-match-data + (eq (null (string-match efs-local-host-regexp t-host)) + (null (string-match efs-local-host-regexp f-host)))))) + (efs-copy-remote-to-remote + f-host-type f-host f-user f-path filename + t-host-type t-host t-user t-path newname + append-p + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 1) + (concat "Copying " (efs-relativize-filename newname))) + ((eq msg 2) + (concat "Copying " (efs-relativize-filename filename))) + (t msg)) + (efs-cont (result line cont-lines) + (filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if result + ;; PASV didn't work. Do things the old-fashioned + ;; way. + (efs-copy-via-temp + filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if cont + (efs-call-cont cont result line cont-lines)))) + nowait xfer-type)) + + ;; Can't do anything direct. Divide and conquer. + (t + (efs-copy-via-temp filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type)))))) + +(defun efs-copy-file (filename newname &optional ok-if-already-exists + keep-date nowait) + ;; Version of copy file for remote files. Actually, will also work + ;; for local files too, since efs-copy-file-internal can copy anything. + ;; If called interactively, copies asynchronously. + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (if (eq ok-if-already-exists 'append) + (setq ok-if-already-exists t)) + (efs-copy-file-internal filename (efs-ftp-path filename) + newname (efs-ftp-path newname) + ok-if-already-exists keep-date 0 nil nowait)) + +;;;; ------------------------------------------------------------ +;;;; File renaming support. +;;;; ------------------------------------------------------------ + +(defun efs-rename-get-file-list (dir ent) + ;; From hashtable ENT for DIR returns a list of all files except "." + ;; and "..". + (let (list) + (efs-map-hashtable + (function + (lambda (key val) + (or (string-equal "." key) (string-equal ".." key) + (setq list + (cons (expand-file-name key dir) list))))) + ent) + list)) + +(defun efs-rename-get-files (dir cont nowait) + ;; Obtains a list of files in directory DIR (except . and ..), and applies + ;; CONT to the list. Doesn't return anything useful. + (let* ((dir (file-name-as-directory dir)) + (ent (efs-get-files-hashtable-entry dir))) + (if ent + (efs-call-cont cont (efs-rename-get-file-list dir ent)) + (efs-ls + dir (efs-ls-guess-switches) t nil t nowait + (efs-cont (listing) (dir cont) + (efs-call-cont + cont (and listing + (efs-rename-get-file-list + dir (efs-get-files-hashtable-entry dir))))))))) + +(defun efs-rename-get-local-file-tree (dir) + ;; Returns a list of the full directory tree under DIR, for DIR on the + ;; local host. The list is in tree order. + (let ((res (list dir))) + (mapcar + (function + (lambda (file) + (if (file-directory-p file) + (nconc res (delq nil (mapcar + (function + (lambda (f) + (and (not (string-equal "." f)) + (not (string-equal ".." f)) + (expand-file-name f file)))) + (directory-files file))))))) + res) + res)) + +(defun efs-rename-get-remote-file-tree (next curr total cont nowait) + ;; Builds a hierarchy of files. + ;; NEXT is the next level so far. + ;; CURR are unprocessed files in the current level. + ;; TOTAL is the processed files so far. + ;; CONT is a cont. function called on the total list after all files + ;; are processed. + ;; NOWAIT non-nil means run asynch. + (or curr (setq curr next + next nil)) + (if curr + (let ((file (car curr))) + (setq curr (cdr curr) + total (cons file total)) + (if (file-directory-p file) + (efs-rename-get-files + file + (efs-cont (list) (next curr total cont nowait) + (efs-rename-get-remote-file-tree (nconc next list) + curr total cont nowait)) + nowait) + (efs-rename-get-remote-file-tree next curr total cont nowait))) + (efs-call-cont cont (nreverse total)))) + +(defun efs-rename-make-targets (files from-dir-len to-dir host user host-type + cont nowait) + ;; Make targets (copy a file or make a subdir) on local or host + ;; for the files in list. Afterwhich, call CONT. + (if files + (let* ((from (car files)) + (files (cdr files)) + (to (concat to-dir (substring from from-dir-len)))) + (if (file-directory-p from) + (if host-type + (let ((dir (nth 2 (efs-ftp-path to)))) + (or (memq host-type efs-unix-host-types) + (memq host-type '(dos os2)) + (setq dir (efs-internal-file-name-as-directory nil dir))) + (efs-send-cmd + host user (list 'mkdir dir) + (format "Making directory %s" (efs-relativize-filename to)) + nil + (efs-cont (res line cont-lines) (to files from-dir-len + to-dir host user + host-type cont nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Making directory" + (format "FTP Error: \"%s\"" line) + to))) + (efs-rename-make-targets + files from-dir-len to-dir host user + host-type cont nowait))) + nowait)) + (condition-case nil + (make-directory-internal to) + (error (efs-call-cont + cont 'failed (format "Failed to mkdir %s" to) ""))) + (efs-rename-make-targets + files from-dir-len to-dir host user host-type cont nowait)) + (efs-copy-file-internal + from (efs-ftp-path from) to (and host-type (efs-ftp-path to)) nil t + (format "Renaming %s to %s" (efs-relativize-filename from) + (efs-relativize-filename to)) + (efs-cont (res line cont-lines) (from to files from-dir-len to-dir + host user host-type cont + nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) from to))) + (efs-rename-make-targets + files from-dir-len to-dir host user host-type cont nowait))) + nowait))) + (if cont (efs-call-cont cont nil "" "")))) + +(defun efs-rename-delete-on-local (files) + ;; Delete the files FILES, and then run CONT. + ;; FILES are assumed to be in inverse tree order. + (message "Deleting files...") + (mapcar + (function + (lambda (f) + (condition-case nil + (if (file-directory-p f) + (delete-directory f) + (delete-file f)) + (file-error nil)))) ; don't complain if the file is already gone. + files) + (message "Deleting files...done")) + +(defun efs-rename-delete-on-remote (files host user host-type cont nowait) + ;; Deletes the list FILES on a remote host. When done calls CONT. + ;; FILES is assumed to be in reverse tree order. + (if files + (let* ((f (car files)) + (rf (nth 2 (efs-ftp-path f)))) + (progn + (setq files (cdr files)) + (if (file-directory-p f) + (let ((rf (if (memq host-type (append efs-unix-host-types + '(dos os2))) + (efs-internal-directory-file-name f) + (efs-internal-file-name-as-directory nil f)))) + + (efs-send-cmd + host user (list 'rmdir rf) + (concat "Deleting directory " (efs-relativize-filename f)) + nil + (efs-cont (res line cont-lines) (f files host user host-type + cont nowait) + (if (and res + (efs-save-match-data + (not (string-match "^550 " line)))) + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Deleting directory" + (format "FTP Error: \"%s\"" line) + f))) + (efs-rename-delete-on-remote + files host user host-type cont nowait))) + nowait)) + (efs-send-cmd + host user (list 'delete rf) + (concat "Deleting " rf) + nil + (efs-cont (res line cont-lines) (f files host user host-type + cont nowait) + (if (and res + (efs-save-match-data + (not (string-match "^550 " line)))) + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Deleting" + (format "FTP Error: \"%s\"" line) + f))) + (efs-rename-delete-on-remote + files host user host-type cont nowait))) + nowait)))) + (if cont (efs-call-cont cont nil "" "")))) + +(defun efs-rename-on-remote (host user old-path new-path old-file new-file + msg nowait cont) + ;; Run a rename command on the remote server. + ;; OLD-PATH and NEW-PATH are in full efs syntax. + ;; OLD-FILE and NEW-FILE are the remote full pathnames, not in efs syntax. + (efs-send-cmd + host user (list 'rename old-file new-file) msg nil + (efs-cont (result line cont-lines) (cont old-path new-path host) + (if result + (progn + (or (and (>= (length line) 4) + (string-equal "550 " (substring line 0 4))) + (efs-set-host-property host 'rnfr-failed t)) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + old-path new-path)))) + (let ((entry (efs-get-file-entry old-path)) + (host-type (efs-host-type host)) + ;; If no file entry, do extra work on the hashtable, + ;; rather than force a listing. + (dir-p (or (not (efs-file-entry-p old-path)) + (file-directory-p old-path)))) + (apply 'efs-add-file-entry host-type new-path + (eq (car entry) t) (cdr entry)) + (efs-delete-file-entry host-type old-path) + (if dir-p + (let* ((old (efs-canonize-file-name + (file-name-as-directory old-path))) + (new (efs-canonize-file-name + (file-name-as-directory new-path))) + (old-len (length old)) + (new-tbl (efs-make-hashtable + (length efs-files-hashtable)))) + (efs-map-hashtable + (function + (lambda (key val) + (if (and (>= (length key) old-len) + (string-equal (substring key 0 old-len) + old)) + (efs-put-hash-entry + (concat new (substring key old-len)) val new-tbl) + (efs-put-hash-entry key val new-tbl)))) + efs-files-hashtable) + (setq efs-files-hashtable new-tbl))) + (if cont (efs-call-cont cont result line cont-lines))))) + nowait)) + +(defun efs-rename-local-to-remote (filename newname newname-parsed + msg cont nowait) + ;; Renames a file from the local host to a remote host. + (if (file-directory-p filename) + (let* ((files (efs-rename-get-local-file-tree filename)) + (to-dir (directory-file-name newname)) + (filename (directory-file-name filename)) + (len (length filename)) + (t-parsed (efs-ftp-path to-dir)) + (host (car t-parsed)) + (user (nth 1 t-parsed)) + (host-type (efs-host-type host))) + ;; MSG is never passed here, instead messages are constructed + ;; internally. I don't know how to use a single message + ;; in a function which sends so many FTP commands. + (efs-rename-make-targets + files len to-dir host user host-type + (efs-cont (result line cont-lines) (files filename newname cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-rename-delete-on-local (nreverse files)) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait)) + (efs-copy-file-internal + filename nil newname newname-parsed t t msg + (efs-cont (result line cont-lines) (filename cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (condition-case nil + (delete-file filename) + (error nil)) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait))) + +(defun efs-rename-from-remote (filename filename-parsed newname newname-parsed + msg cont nowait) + (let ((f-host (car filename-parsed)) + (f-user (nth 1 filename-parsed)) + (fast-nowait (if (eq nowait t) 1 nowait))) + (if (file-directory-p filename) + (let* ((t-host (car newname-parsed)) + (t-user (nth 1 newname-parsed)) + (t-host-type (and t-host (efs-host-type t-host))) + (f-host-type (efs-host-type f-host))) + (efs-rename-get-remote-file-tree + nil (list filename) nil + (efs-cont (list) (filename filename-parsed newname t-host t-user + t-host-type f-host f-user f-host-type + cont fast-nowait) + (efs-rename-make-targets + list (length filename) newname t-host t-user t-host-type + (efs-cont (res line cont-lines) (filename newname f-host f-user + f-host-type list cont + fast-nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-rename-delete-on-remote + (nreverse list) f-host f-user f-host-type cont + fast-nowait))) + fast-nowait)) nowait)) + ;; Do things the simple way. + (let ((f-path (nth 2 filename-parsed)) + (f-abbr (efs-relativize-filename filename))) + (efs-copy-file-internal + filename filename-parsed newname newname-parsed t t msg + (efs-cont (result line cont-lines) (filename newname f-host f-user + f-path f-abbr + cont fast-nowait) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-send-cmd + f-host f-user (list 'delete f-path) + (format "Removing %s" f-abbr) nil + (efs-cont (result line cont-lines) (filename f-host cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "Failed to remove %s" + filename) + "FTP Error: \"%s\"" line))) + (efs-delete-file-entry (efs-host-type f-host) + filename) + (if cont + (efs-call-cont cont result line cont-lines)))) + fast-nowait))) nowait))))) + +(defun efs-rename-file-internal (filename newname ok-if-already-exists + &optional msg cont nowait) + ;; Internal version of rename-file for remote files. + ;; Takes CONT and NOWAIT args. + (let ((filename (expand-file-name filename)) + (newname (expand-file-name newname))) + (let ((f-parsed (efs-ftp-path filename)) + (t-parsed (efs-ftp-path newname))) + (if (null (or f-parsed t-parsed)) + (progn + ;; local rename + (rename-file filename newname ok-if-already-exists) + (if cont + (efs-call-cont cont nil "Renamed locally" ""))) + + ;; check to see if we can overwrite + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "rename to it" (numberp ok-if-already-exists))) + + (let ((f-abbr (efs-relativize-filename filename)) + (t-abbr (efs-relativize-filename newname + (file-name-directory filename) + filename))) + (or msg (setq msg (format "Renaming %s to %s" f-abbr t-abbr))) + (if f-parsed + (let* ((f-host (car f-parsed)) + (f-user (nth 1 f-parsed)) + (f-path (nth 2 f-parsed)) + (f-host-type (efs-host-type f-host))) + (if (and t-parsed + (string-equal (downcase f-host) + (downcase (car t-parsed))) + (not (efs-get-host-property f-host 'rnfr-failed)) + (if (memq f-host-type efs-case-insensitive-host-types) + (string-equal (downcase f-user) + (downcase (nth 1 t-parsed))) + (string-equal f-user (nth 1 t-parsed)))) + ;; Can run a RENAME command on the server. + (efs-rename-on-remote + f-host f-user filename newname f-path (nth 2 t-parsed) + msg nowait + (efs-cont (result line cont-lines) (f-host + filename + newname + ok-if-already-exists + msg cont nowait) + (if result + (progn + (efs-set-host-property f-host 'rnfr-failed t) + (efs-rename-file-internal + filename newname ok-if-already-exists msg cont + (if (eq nowait t) 1 nowait))) + (if cont + (efs-call-cont cont result line cont-lines))))) + ;; remote to remote + (efs-rename-from-remote filename f-parsed newname t-parsed + msg cont nowait))) + ;; local to remote + (efs-rename-local-to-remote + filename newname t-parsed msg cont nowait))))))) + +(defun efs-rename-file (filename newname &optional ok-if-already-exists nowait) + ;; Does file renaming for remote files. + (efs-rename-file-internal filename newname ok-if-already-exists + nil nil nowait)) + +;;;; ------------------------------------------------------------ +;;;; Making symbolic and hard links. +;;;; ------------------------------------------------------------ + +;;; These functions require that the remote FTP server understand +;;; SITE EXEC and that ln is in its the ftp-exec path. + +(defun efs-try-ln (host user cont nowait) + ;; Do some preemptive testing to see if exec ln works + (if (efs-get-host-property host 'exec-failed) + (signal 'ftp-error (list "Unable to exec ln on host" host))) + (let ((exec-ln (efs-get-host-property host 'exec-ln))) + (cond + ((eq exec-ln 'failed) + (signal 'ftp-error (list "ln is not in FTP exec path on host" host))) + ((eq exec-ln 'works) + (efs-call-cont cont)) + (t + (message "Checking for ln executable on %s..." host) + (efs-send-cmd + host user '(quote site exec "ln / /") + nil nil + (efs-cont (result line cont-lines) (host user cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + ;; Look for an error message + (if (efs-save-match-data + (string-match "\n200-" cont-lines)) + (progn + (efs-set-host-property host 'exec-ln 'works) + (efs-call-cont cont)) + (efs-set-host-property host 'exec-ln 'failed) + (efs-error host user + (format "ln not in FTP exec path on host %s" host))))) + nowait))))) + +(defun efs-make-symbolic-link-internal + (target linkname &optional ok-if-already-exists cont nowait) + ;; Makes remote symbolic links. Assumes that linkname is already expanded. + (let* ((parsed (efs-ftp-path linkname)) + (host (car parsed)) + (user (nth 1 parsed)) + (linkpath (nth 2 parsed)) + (abbr (efs-relativize-filename linkname + (file-name-directory target) target)) + (tparsed (efs-ftp-path target)) + (com-target target) + cmd-string) + (if (null (file-directory-p + (file-name-directory linkname))) + (if cont + (efs-call-cont cont 'failed + (format "no such file or directory, %s" linkname) + "") + (signal 'file-error (list "no such file or directory" linkname))) + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + linkname "make symbolic link" (numberp ok-if-already-exists))) + ;; Do this after above, so that hopefully the host type is sorted out + ;; by now. + (let ((host-type (efs-host-type host))) + (if (or (not (memq host-type efs-unix-host-types)) + (memq host-type efs-dumb-host-types) + (efs-get-host-property host 'exec-failed)) + (error "Unable to make symbolic links on %s." host))) + ;; Be careful not to spoil relative links, or symlinks to other + ;; machines, which maybe symlink-fix.el can sort out. + (if (and tparsed + (string-equal (downcase (car tparsed)) (downcase host)) + (string-equal (nth 1 tparsed) user)) + (setq com-target (nth 2 tparsed))) + ;; symlinks only work for unix, so don't need to + ;; convert pathnames. What about VOS? + (setq cmd-string (concat "ln -sf " com-target " " linkpath)) + (efs-try-ln + host user + (efs-cont () (host user cmd-string target linkname com-target + abbr cont nowait) + (efs-send-cmd + host user (list 'quote 'site 'exec cmd-string) + (format "Symlinking %s to %s" target abbr) + nil + (efs-cont (result line cont-lines) (host user com-target linkname + cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (efs-add-file-entry nil linkname com-target nil user) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait)) + nowait)))) + +(defun efs-make-symbolic-link (target linkname &optional ok-if-already-exists) + ;; efs version of make-symbolic-link + (let* ((linkname (expand-file-name linkname)) + (parsed (efs-ftp-path linkname))) + (if parsed + (efs-make-symbolic-link-internal target linkname ok-if-already-exists) + ;; Handler will match on either target or linkname. We are only + ;; interested in the linkname. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-file-handler-function))) + (make-symbolic-link target linkname ok-if-already-exists))))) + +(defun efs-add-name-to-file-internal + (file newname &optional ok-if-already-exists cont nowait) + ;; Makes remote symbolic links. Assumes that linkname is already expanded. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (nparsed (efs-ftp-path newname)) + (nhost (car nparsed)) + (nuser (nth 1 nparsed)) + (npath (nth 2 nparsed)) + (abbr (efs-relativize-filename newname + (file-name-directory file))) + (ent (efs-get-file-entry file)) + cmd-string) + (or (and (string-equal (downcase host) (downcase nhost)) + (string-equal user nuser)) + (error "Cannot create hard links between different host user pairs.")) + (if (or (null ent) (stringp (car ent)) + (not (file-directory-p + (file-name-directory newname)))) + (if cont + (efs-call-cont cont 'failed + (format "no such file or directory, %s %s" + file newname) "") + (signal 'file-error + (list "no such file or directory" + file newname))) + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "make hard link" (numberp ok-if-already-exists))) + ;; Do this last, so that hopefully the host type is known. + (let ((host-type (efs-host-type host))) + (if (or (not (memq host-type efs-unix-host-types)) + (memq host-type efs-dumb-host-types) + (efs-get-host-property host 'exec-failed)) + (error "Unable to make hard links on %s." host))) + (setq cmd-string (concat "ln -f " path " " npath)) + (efs-try-ln + host user + (efs-cont () (host user cmd-string file newname abbr cont nowait) + (efs-send-cmd + host user (list 'quote 'site 'exec cmd-string) + (format "Adding to %s name %s" file abbr) + nil + (efs-cont (result line cont-lines) (host user file newname cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (let ((ent (efs-get-file-entry file))) + (if ent + (let ((nlinks (nthcdr 4 ent)) + new-nlinks) + (and (integerp (car nlinks)) + (setq new-nlinks (1+ (car nlinks))) + (setcar nlinks new-nlinks)) + (apply 'efs-add-file-entry nil newname ent) + (if cont (efs-call-cont cont nil line cont-lines))) + (let ((tbl (efs-get-files-hashtable-entry + (file-name-directory + (directory-file-name newname))))) + (if tbl + (efs-ls + newname + (concat (efs-ls-guess-switches) "d") t t nil + nowait + (efs-cont (listing) (newname cont line cont-lines) + (efs-update-file-info + newname efs-data-buffer-name) + (if cont + (efs-call-cont cont nil line cont-lines)))) + (if cont + (efs-call-cont cont nil line cont-lines)))))))))) + nowait)) + nowait)))) + +(defun efs-add-name-to-file (file newname &optional ok-if-already-exists) + ;; efs version of add-name-to-file + (efs-add-name-to-file-internal file newname ok-if-already-exists)) + + +;;;; ============================================================== +;;;; >9 +;;;; Multiple Host Type Support. +;;;; The initial host type guessing is done in the PWD code below. +;;;; If necessary, further guessing is done in the listing parser. +;;;; ============================================================== + + +;;;; -------------------------------------------------------------- +;;;; Functions for setting and retrieving host types. +;;;; -------------------------------------------------------------- + +(defun efs-add-host (type host) + "Sets the TYPE of the remote host HOST. +The host type is read with completion so this can be used to obtain a +list of supported host types. HOST must be a string, giving the name of +the host, exactly as given in file names. Setting the host type with +this function is preferable to setting the efs-TYPE-host-regexp, as look up +will be faster. Returns TYPE." + ;; Since internet host names are always case-insensitive, we will cache + ;; them in lower case. + (interactive + (list + (intern + (completing-read "Host type: " + (mapcar + (function (lambda (elt) + (list (symbol-name (car elt))))) + efs-host-type-alist) + nil t)) + (read-string "Host: " + (let ((name (or (buffer-file-name) + (and (eq major-mode 'dired-mode) + dired-directory)))) + (and name (car (efs-ftp-path name))))))) + (setq host (downcase host)) + (efs-set-host-property host 'host-type type) + (prog1 + (setq efs-host-cache host + efs-host-type-cache type) + (efs-set-process-host-type host))) + +(defun efs-set-process-host-type (host &optional user) + ;; Sets the value of efs-process-host-type so that it is shown + ;; on the mode-line. + (let ((buff-list (buffer-list))) + (save-excursion + (while buff-list + (set-buffer (car buff-list)) + (if (equal efs-process-host host) + (setq efs-process-host-type (concat " " (symbol-name + (efs-host-type host)))) + (and efs-show-host-type-in-dired + (eq major-mode 'dired-mode) + efs-dired-host-type + (string-equal (downcase + (car (efs-ftp-path default-directory))) + (downcase host)) + (if user + (setq efs-dired-listing-type-string + (concat + " " + (symbol-name (efs-listing-type host user)))) + (or efs-dired-listing-type-string + (setq efs-dired-listing-type-string + (concat " " (symbol-name (efs-host-type host)))))))) + (setq buff-list (cdr buff-list)))))) + +;;;; ---------------------------------------------------------------- +;;;; Functions for setting and retrieving listings types. +;;;; ---------------------------------------------------------------- + +;;; listing types?? +;;; These are distinguished from host types, in case some OS's have two +;;; breeds of listings. e.g. Unix descriptive listings. +;;; We also use this to support the myriad of DOS ftp servers. + + +(defun efs-listing-type (host user) + "Returns the type of listing used on HOST by USER. +If there is no entry for a specialized listing, returns the host type." + (or + (efs-get-host-user-property host user 'listing-type) + (efs-host-type host user))) + +(defun efs-add-listing-type (type host user) + "Interactively adds the specialized listing type TYPE for HOST and USER +to the listing type cache." + (interactive + (let ((name (or (buffer-file-name) + (and (eq major-mode 'dired-mode) + dired-directory)))) + (list + (intern + (completing-read "Listing type: " + (mapcar + (function (lambda (elt) + (list (symbol-name elt)))) + efs-listing-types) + nil t)) + (read-string "Host: " + (and name (car (efs-ftp-path name)))) + (read-string "User: " + (and name (nth 1 (efs-ftp-path name))))))) + (efs-set-host-user-property host user 'listing-type type) + (efs-set-process-host-type host user)) + +;;;; -------------------------------------------------------------- +;;;; Auotomagic bug reporting for unrecognized host types. +;;;; -------------------------------------------------------------- + +(defun efs-scream-and-yell-1 (host user) + ;; Internal for efs-scream-and-yell. + (with-output-to-temp-buffer "*Help*" + (princ + (format + "efs is unable to identify the remote host type of %s. + +Please report this as a bug. It would be very helpful +if your bug report contained at least the PWD command +within the *ftp %s@%s* buffer. +If you know them, also send the operating system +and ftp server types of the remote host." host user host))) + (if (y-or-n-p "Would you like to submit a bug report now? ") + (efs-report-bug host user + "Bug occurred during efs-guess-host-type." t))) + +(defun efs-scream-and-yell (host user) + ;; Advertises that something has gone wrong in identifying the host type. + (if (eq (selected-window) (minibuffer-window)) + (efs-abort-recursive-edit-and-then 'efs-scream-and-yell-1 host user) + (efs-scream-and-yell-1 host user) + (error "Unable to identify remote host type"))) + +;;;; -------------------------------------------------------- +;;;; Guess at the host type using PWD syntax. +;;;; -------------------------------------------------------- + +;; host-type path templates. These should match a pwd performed +;; as the first command after connecting. They should be as tight +;; as possible + +(defconst efs-unix-path-template "^/") +(defconst efs-apollo-unix-path-template "^//") +(defconst efs-cms-path-template + (concat + "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" + "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$\\|" + ;; For the SFS version of CMS + "^[-A-Z0-9]+:[-A-Z0-9$*]+\\.$")) + +(defconst efs-mvs-path-template "^'?[A-Z][0-9][0-9]?[0-9]?[0-9]?[0-9]?\\.'?") + +(defconst efs-guardian-path-template + (concat + "^\\(" + "\\\\[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." + "\\)?" + "\\$[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." + "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?$")) +;; guardian and cms are very close to overlapping (they don't). Be careful. +(defconst efs-vms-path-template + "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") +(defconst efs-mts-path-template + "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") +(defconst efs-ms-unix-path-template "^[A-Za-z0-9]:/") + +;; Following two are for TI lisp machines. Note that lisp machines +;; do not have a default directory, but only a default pathname against +;; which relative pathnames are merged (Jamie tells me). +(defconst efs-ti-explorer-pwd-line-template + (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") + (token (concat "[^" excluded-chars "]+"))) + (concat "^250 " + token ": " ; host name + token "\\(\\." token "\\)*; " ; directory + "\\(\\*.\\*\\|\\*\\)#\\(\\*\\|>\\)" ; name, ext, version + "$"))) ; "*.*#*" or "*.*#>" or "*#*" or "*#>" or "#*" ... +(defconst efs-ti-twenex-path-template + (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") + (token (concat "[^" excluded-chars "]+"))) + (concat "^" + token ":" ; host name + "<\\(" token "\\)?\\(\\." token "\\)*>" ; directory + "\\(\\*.\\*\\|\\*\\)" ; name and extension + "$"))) + +(defconst efs-tops-20-path-template + "^[-A-Z0-9_$]+:<[-A-Z0-9_$]\\(.[-A-Z0-9_$]+\\)*>$") +(defconst efs-pc-path-template + "^[a-zA-Z0-9]:\\\\\\([-_+=a-zA-Z0-9.]+\\\\\\)*[-_+=a-zA-Z0-9.]*$") +(defconst efs-mpe-path-template + (let ((token (concat "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?" + "[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?"))) + (concat + ;; optional session name + "^\\(" token "\\)?," + ;; username + token "." + ;; account + token "," + ;; group + token "$"))) +(defconst efs-vos-path-template + (let ((token "[][@\\^`{}|~\"$+,---./:_a-zA-Z0-9]+")) + (concat + "%" token ; host + "#" token ; disk + "\\(>" token "\\)+" ; directories + ))) +(defconst efs-netware-path-template "^[-A-Z0-9_][-A-Z0-9_/]*:/") +;; Sometimes netware doesn't return a device to a PWD. Then it will be +;; recognized by the listing parser. + +(defconst efs-nos-ve-path-template "^:[A-Z0-9]") +;; Matches the path for NOS/VE + +(defconst efs-mvs-pwd-line-template + ;; Not sure how the PWD parser will do with empty strings, so treate + ;; this as a line regexp. + "^257 \\([Nn]o prefix defined\\|\"\" is working directory\\)") +(defconst efs-cms-pwd-line-template + "^450 No current working directory defined$") +(defconst efs-tops-20-pwd-line-template + "^500 I never heard of the \\(XPWD\\|PWD\\) command\\. Try HELP\\.$") +(defconst efs-dos:ftp-pwd-line-template + "^250 Current working directory is +") +(defconst efs-coke-pwd-line-template "^257 Current balance \\$[0-9]") + +(defconst efs-super-dumb-unix-tilde-regexp + "^550 /.*: No such file or directory\\.?$") +(defconst efs-cms-knet-tilde-regexp + "^501 Invalid CMS fileid: ~$") + + +;; It might be nice to message users about the host type identified, +;; but there is so much other messaging going on, it would not be +;; seen. No point in slowing things down just so users can read +;; a host type message. + +(defun efs-guess-host-type (host user) + "Guess the host type of HOST. +Does a PWD and examines the directory syntax. The PWD is then cached for use +in file name expansion." + (let ((host-type (efs-host-type host)) + (key (concat host "/" user "/~")) + syst) + (efs-save-match-data + (if (eq host-type 'unknown) + ;; Note that efs-host-type returns unknown as the default. + ;; Since we don't yet know the host-type, we use the default + ;; version of efs-send-pwd. We compensate if necessary + ;; by looking at the entire line of output. + (let* ((result (efs-send-pwd nil host user)) + (dir (car result)) + (line (cdr result))) + (cond + + ;; First sift through process lines to see if we recognize + ;; any pwd errors, or full line messages. + + ;; CMS + ((string-match efs-cms-pwd-line-template line) + (setq host-type (efs-add-host 'cms host) + dir (concat "/" (if (> (length user) 8) + (substring user 0 8) + user) + ".191")) + (message + "Unable to determine a \"home\" CMS minidisk. Assuming %s" + dir) + (sit-for 1)) + + ;; TOPS-20 + ((string-match efs-tops-20-pwd-line-template line) + (setq host-type (efs-add-host 'tops-20 host) + dir (car (efs-send-pwd 'tops-20 host user)))) + + ;; TI-EXPLORER lisp machine. pwd works here, but the output + ;; needs to be specially parsed since spaces separate + ;; hostnames from dirs from filenames. + ((string-match efs-ti-explorer-pwd-line-template line) + (setq host-type (efs-add-host 'ti-explorer host) + dir (substring line 4))) + + ;; FTP Software's DOS Server + ((string-match efs-dos:ftp-pwd-line-template line) + (setq host-type (efs-add-host 'dos host) + dir (substring line (match-end 0))) + (efs-add-listing-type 'dos:ftp host user)) + + ;; MVS + ((string-match efs-mvs-pwd-line-template line) + (setq host-type (efs-add-host 'mvs host) + dir "")) ; "" will convert to /, which is always + ; the mvs home dir. + + ;; COKE + ((string-match efs-coke-pwd-line-template line) + (setq host-type (efs-add-host 'coke host) + dir "/")) + + ;; Try to get tilde. + ((null dir) + (let ((tilde (nth 1 (efs-send-cmd + host user (list 'get "~" "/dev/null"))))) + (cond + ;; super dumb unix + ((string-match efs-super-dumb-unix-tilde-regexp tilde) + (setq dir (car (efs-send-pwd 'super-dumb-unix host user)) + host-type (efs-add-host 'super-dumb-unix host))) + + ;; Try for cms-knet + ((string-match efs-cms-knet-tilde-regexp tilde) + (setq dir (car (efs-send-pwd 'cms-knet host user)) + host-type (efs-add-host 'cms-knet host))) + + ;; We don't know. Scream and yell. + (efs-scream-and-yell host user)))) + + ;; Now look at dir to determine host type + + ;; try for UN*X-y type stuff + ((string-match efs-unix-path-template dir) + (if + ;; Check for apollo, so we know not to short-circuit //. + (string-match efs-apollo-unix-path-template dir) + (progn + (setq host-type (efs-add-host 'apollo-unix host)) + (efs-add-listing-type 'unix:unknown host user)) + ;; could be ka9q, dos-distinct, plus any of the unix breeds, + ;; except apollo. + (if (setq syst (efs-get-syst host user)) + (let ((case-fold-search t)) + (cond + ((string-match "\\bNetware\\b" syst) + (setq host-type (efs-add-host 'netware host))) + ((string-match "^Plan 9" syst) + (setq host-type (efs-add-host 'plan9 host))) + ((string-match "^UNIX" syst) + (setq host-type (efs-add-host 'unix host)) + (efs-add-listing-type 'unix:unknown host user))))))) + + ;; try for VMS + ((string-match efs-vms-path-template dir) + (setq host-type (efs-add-host 'vms host))) + + ;; try for MTS + ((string-match efs-mts-path-template dir) + (setq host-type (efs-add-host 'mts host))) + + ;; try for CMS + ((string-match efs-cms-path-template dir) + (setq host-type (efs-add-host 'cms host))) + + ;; try for Tandem's guardian OS + ((string-match efs-guardian-path-template dir) + (setq host-type (efs-add-host 'guardian host))) + + ;; Try for TOPS-20. pwd doesn't usually work for tops-20 + ;; But who knows??? + ((string-match efs-tops-20-path-template dir) + (setq host-type (efs-add-host 'tops-20 host))) + + ;; Try for DOS or OS/2. + ((string-match efs-pc-path-template dir) + (let ((syst (efs-get-syst host user)) + (case-fold-search t)) + (if (and syst (string-match "^OS/2 " syst)) + (setq host-type (efs-add-host 'os2 host)) + (setq host-type (efs-add-host 'dos host))))) + + ;; try for TI-TWENEX lisp machine + ((string-match efs-ti-twenex-path-template dir) + (setq host-type (efs-add-host 'ti-twenex host))) + + ;; try for MPE + ((string-match efs-mpe-path-template dir) + (setq host-type (efs-add-host 'mpe host))) + + ;; try for VOS + ((string-match efs-vos-path-template dir) + (setq host-type (efs-add-host 'vos host))) + + ;; try for the microsoft server in unix mode + ((string-match efs-ms-unix-path-template dir) + (setq host-type (efs-add-host 'ms-unix host))) + + ;; Netware? + ((string-match efs-netware-path-template dir) + (setq host-type (efs-add-host 'netware host))) + + ;; Try for MVS + ((string-match efs-mvs-path-template dir) + (if (string-match "^'.+'$" dir) + ;; broken MVS PWD quoting + (setq dir (substring dir 1 -1))) + (setq host-type (efs-add-host 'mvs host))) + + ;; Try for NOS/VE + ((string-match efs-nos-ve-path-template dir) + (setq host-type (efs-add-host 'nos-ve host))) + + ;; We don't know. Scream and yell. + (t + (efs-scream-and-yell host user))) + + ;; Now that we have done a pwd, might as well put it in + ;; the expand-dir hashtable. + (if dir + (efs-put-hash-entry + key + (efs-internal-directory-file-name + (efs-fix-path host-type dir 'reverse)) + efs-expand-dir-hashtable + (memq host-type efs-case-insensitive-host-types)))) + + ;; host-type has been identified by regexp, set the mode-line. + (efs-set-process-host-type host user) + + ;; Some special cases, where we need to store the cwd on login. + (if (not (efs-hash-entry-exists-p + key efs-expand-dir-hashtable)) + (cond + ;; CMS: We will be doing cd's, so we'd better make sure that + ;; we know where home is. + ((eq host-type 'cms) + (let* ((res (efs-send-pwd 'cms host user)) + (dir (car res)) + (line (cdr res))) + (if (and dir (not (string-match + efs-cms-pwd-line-template line))) + (setq dir (concat "/" dir)) + (setq dir (concat "/" (if (> (length user) 8) + (substring user 0 8) + user) + ".191")) + (message + "Unable to determine a \"home\" CMS minidisk. Assuming %s" + dir)) + (efs-put-hash-entry + key dir efs-expand-dir-hashtable + (memq 'cms efs-case-insensitive-host-types)))) + ;; MVS: pwd doesn't work in the root directory, so we stuff this + ;; into the hashtable manually. + ((eq host-type 'mvs) + (efs-put-hash-entry key "/" efs-expand-dir-hashtable)) + )))))) + + +;;;; ----------------------------------------------------------- +;;;; efs-autoloads +;;;; These provide the entry points for the non-unix packages. +;;;; ----------------------------------------------------------- + +(efs-autoload 'efs-fix-path vms "efs-vms") +(efs-autoload 'efs-fix-path mts "efs-mts") +(efs-autoload 'efs-fix-path cms "efs-cms") +(efs-autoload 'efs-fix-path ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-fix-path ti-twenex "efs-ti-twenex") +(efs-autoload 'efs-fix-path dos "efs-pc") +(efs-autoload 'efs-fix-path mvs "efs-mvs") +(efs-autoload 'efs-fix-path tops-20 "efs-tops-20") +(efs-autoload 'efs-fix-path mpe "efs-mpe") +(efs-autoload 'efs-fix-path os2 "efs-pc") +(efs-autoload 'efs-fix-path vos "efs-vos") +(efs-autoload 'efs-fix-path ms-unix "efs-ms-unix") +(efs-autoload 'efs-fix-path netware "efs-netware") +(efs-autoload 'efs-fix-path cms-knet "efs-cms-knet") +(efs-autoload 'efs-fix-path guardian "efs-guardian") +(efs-autoload 'efs-fix-path nos-ve "efs-nos-ve") + +(efs-autoload 'efs-fix-dir-path vms "efs-vms") +(efs-autoload 'efs-fix-dir-path mts "efs-mts") +(efs-autoload 'efs-fix-dir-path cms "efs-cms") +(efs-autoload 'efs-fix-dir-path ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-fix-dir-path ti-twenex "efs-ti-twenex") +(efs-autoload 'efs-fix-dir-path dos "efs-pc") +(efs-autoload 'efs-fix-dir-path mvs "efs-mvs") +(efs-autoload 'efs-fix-dir-path tops-20 "efs-tops-20") +(efs-autoload 'efs-fix-dir-path mpe "efs-mpe") +(efs-autoload 'efs-fix-dir-path os2 "efs-pc") +(efs-autoload 'efs-fix-dir-path vos "efs-vos") +(efs-autoload 'efs-fix-dir-path hell "efs-hell") +(efs-autoload 'efs-fix-dir-path ms-unix "efs-ms-unix") +(efs-autoload 'efs-fix-dir-path netware "efs-netware") +(efs-autoload 'efs-fix-dir-path plan9 "efs-plan9") +(efs-autoload 'efs-fix-dir-path cms-knet "efs-cms-knet") +(efs-autoload 'efs-fix-dir-path guardian "efs-guardian") +(efs-autoload 'efs-fix-dir-path nos-ve "efs-nos-ve") +(efs-autoload 'efs-fix-dir-path coke "efs-coke") + +;; A few need to autoload a pwd function +(efs-autoload 'efs-send-pwd tops-20 "efs-tops-20") +(efs-autoload 'efs-send-pwd cms-knet "efs-cms-knet") +(efs-autoload 'efs-send-pwd ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-send-pwd hell "efs-hell") +(efs-autoload 'efs-send-pwd mvs "efs-mvs") +(efs-autoload 'efs-send-pwd coke "efs-coke") + +;; A few packages are loaded by the listing parser. +(efs-autoload 'efs-parse-listing ka9q "efs-ka9q") +(efs-autoload 'efs-parse-listing unix:dl "efs-dl") +(efs-autoload 'efs-parse-listing dos-distinct "efs-dos-distinct") +(efs-autoload 'efs-parse-listing hell "efs-hell") +(efs-autoload 'efs-parse-listing netware "efs-netware") + +;; Packages that need to autoload for child-lookup +(efs-autoload 'efs-allow-child-lookup plan9 "efs-plan9") +(efs-autoload 'efs-allow-child-lookup coke "efs-coke") + +;; Packages that need to autoload for file-exists-p and file-directory-p +(efs-autoload 'efs-internal-file-exists-p guardian "efs-guardian") +(efs-autoload 'efs-internal-file-directory-p guardian "efs-guardian") + + + +;;;; ============================================================ +;;;; >10 +;;;; Attaching onto the appropriate Emacs version +;;;; ============================================================ + +;;;; ------------------------------------------------------------------- +;;;; Connect to various hooks. +;;;; ------------------------------------------------------------------- + +(or (memq 'efs-set-buffer-mode find-file-hooks) + (setq find-file-hooks + (cons 'efs-set-buffer-mode find-file-hooks))) + +;;; We are using our own dired.el, so this doesn't depend on Emacs flavour. + +(if (featurep 'dired) + (require 'efs-dired) + (add-hook 'dired-load-hook (function + (lambda () + (require 'efs-dired))))) + +;;;; ------------------------------------------------------------ +;;;; Add to minor-mode-alist. +;;;; ------------------------------------------------------------ + +(or (assq 'efs-process-host-type minor-mode-alist) + (if (assq 'dired-sort-mode minor-mode-alist) + (let ((our-list + (nconc + (delq nil + (list (assq 'dired-sort-mode minor-mode-alist) + (assq 'dired-subdir-omit minor-mode-alist) + (assq 'dired-marker-stack minor-mode-alist))) + (list '(efs-process-host-type efs-process-host-type) + '(efs-dired-listing-type + efs-dired-listing-type-string)))) + (old-list (delq + (assq 'efs-process-host-type minor-mode-alist) + (delq + (assq 'efs-dired-listing-type minor-mode-alist) + minor-mode-alist)))) + (setq minor-mode-alist nil) + (while old-list + (or (assq (car (car old-list)) our-list) + (setq minor-mode-alist (nconc minor-mode-alist + (list (car old-list))))) + (setq old-list (cdr old-list))) + (setq minor-mode-alist (nconc our-list minor-mode-alist))) + (setq minor-mode-alist + (nconc + (list '(efs-process-host-type efs-process-host-type) + '(efs-dired-listing-type efs-dired-listing-type-string)) + minor-mode-alist)))) + +;;;; ------------------------------------------------------------ +;;;; File name handlers +;;;; ------------------------------------------------------------ + +(defun efs-file-handler-function (operation &rest args) + "Function to call special file handlers for remote files." + (let ((handler (get operation 'efs))) + (if handler + (apply handler args) + (let ((inhibit-file-name-handlers + (cons 'efs-file-handler-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))))) + +(defun efs-sifn-handler-function (operation &rest args) + ;; Handler function for substitute-in-file-name + (if (eq operation 'substitute-in-file-name) + (apply 'efs-substitute-in-file-name args) + (let ((inhibit-file-name-handlers + (cons 'efs-sifn-handler-function + (and (eq operation inhibit-file-name-operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args)))) + +;; Yes, this is what it looks like. I'm defining the handler to run our +;; version whenever there is an environment variable. + +(nconc file-name-handler-alist + (list + (cons "\\(^\\|[^$]\\)\\(\\$\\$\\)*\\$[{a-zA-Z0-9]" + 'efs-sifn-handler-function))) + +;;;; ------------------------------------------------------------ +;;;; Necessary overloads. +;;;; ------------------------------------------------------------ + +;;; The following functions are overloaded, instead of extended via +;;; the file-name-handler-alist. For various reasons, the +;;; file-name-handler-alist doesn't work for them. It would be nice if +;;; this list could be shortened in the future. + +;; File name exansion. It is not until _after_ a file name has been +;; expanded that it is reasonable to test it for a file name handler. +(efs-overwrite-fn "efs" 'expand-file-name) + +;; Loading lisp files. The problem with using the file-name-handler-alist +;; here is that we don't know what is to be handled, until after searching +;; the load-path. The solution is to change the C code for Fload. +;; A patch to do this has been written by Jay Adams . +(efs-overwrite-fn "efs" 'load) +(efs-overwrite-fn "efs" 'require) + +;;;; ------------------------------------------------------------ +;;;; Install the file handlers for efs-file-handler-function. +;;;; ------------------------------------------------------------ + +;; I/O +(put 'insert-file-contents 'efs 'efs-insert-file-contents) +(put 'write-region 'efs 'efs-write-region) +(put 'directory-files 'efs 'efs-directory-files) +(put 'list-directory 'efs 'efs-list-directory) +(put 'insert-directory 'efs 'efs-insert-directory) +(put 'recover-file 'efs 'efs-recover-file) +;; file properties +(put 'file-directory-p 'efs 'efs-file-directory-p) +(put 'file-writable-p 'efs 'efs-file-writable-p) +(put 'file-readable-p 'efs 'efs-file-readable-p) +(put 'file-executable-p 'efs 'efs-file-executable-p) +(put 'file-symlink-p 'efs 'efs-file-symlink-p) +(put 'file-attributes 'efs 'efs-file-attributes) +(put 'file-exists-p 'efs 'efs-file-exists-p) +(put 'file-accessible-directory-p 'efs 'efs-file-accessible-directory-p) +;; manipulating file names +(put 'file-name-directory 'efs 'efs-file-name-directory) +(put 'file-name-nondirectory 'efs 'efs-file-name-nondirectory) +(put 'file-name-as-directory 'efs 'efs-file-name-as-directory) +(put 'directory-file-name 'efs 'efs-directory-file-name) +(put 'abbreviate-file-name 'efs 'efs-abbreviate-file-name) +(put 'file-name-sans-versions 'efs 'efs-file-name-sans-versions) +(put 'unhandled-file-name-directory 'efs 'efs-unhandled-file-name-directory) +(put 'diff-latest-backup-file 'efs 'efs-diff-latest-backup-file) +(put 'file-truename 'efs 'efs-file-truename) +;; modtimes +(put 'verify-visited-file-modtime 'efs 'efs-verify-visited-file-modtime) +(put 'file-newer-than-file-p 'efs 'efs-file-newer-than-file-p) +(put 'set-visited-file-modtime 'efs 'efs-set-visited-file-modtime) +;; file modes +(put 'set-file-modes 'efs 'efs-set-file-modes) +(put 'file-modes 'efs 'efs-file-modes) +;; buffers +(put 'backup-buffer 'efs 'efs-backup-buffer) +(put 'get-file-buffer 'efs 'efs-get-file-buffer) +(put 'create-file-buffer 'efs 'efs-create-file-buffer) +;; creating and removing files +(put 'delete-file 'efs 'efs-delete-file) +(put 'copy-file 'efs 'efs-copy-file) +(put 'rename-file 'efs 'efs-rename-file) +(put 'file-local-copy 'efs 'efs-file-local-copy) +(put 'make-directory-internal 'efs 'efs-make-directory-internal) +(put 'delete-directory 'efs 'efs-delete-directory) +(put 'add-name-to-file 'efs 'efs-add-name-to-file) +(put 'make-symbolic-link 'efs 'efs-make-symbolic-link) +;; file name completion +(put 'file-name-completion 'efs 'efs-file-name-completion) +(put 'file-name-all-completions 'efs 'efs-file-name-all-completions) + +;;;; ------------------------------------------------------------ +;;;; Finally run any load-hooks. +;;;; ------------------------------------------------------------ + +(run-hooks 'efs-load-hook) + +;;; end of efs.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/emacs-19.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/emacs-19.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,484 @@ +;;;; Emacs 19 compatibility functions for use in Emacs 18. +;;;; Based on: $Id: emacs-19.el,v 1.1 1997/02/11 05:05:14 steve Exp $ +;;;; +;;;; Rewritten by sandy@ibm550.sissa.it after gnu emacs 19 was +;;;; released to make it closer to V19. +;;;; Last modified: Sun Jun 12 00:06:06 1994 by sandy on ibm550 + +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to roland@ai.mit.edu) or from +;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +;;; 02139, USA. + +;; These functions are used in dired.el, but are also of general +;; interest, so you may want to add this to your .emacs: +;; +;; (autoload 'make-directory "emacs-19" "Make a directory." t) +;; (autoload 'delete-directory "emacs-19" "Remove a directory." t) +;; (autoload 'member "emacs-19" "Like memq, but uses `equal' instead of `eq'.") +;; (autoload 'compiled-function-p "emacs-19" "Emacs 18 doesn't have these.") + +(provide 'emacs-19) + +;;; Variables + +(defvar insert-directory-program "ls" + "Absolute or relative name of the `ls' program used by `insert-directory'.") + +(defvar bv-length) ; make the byte compiler a happy camper + +(defconst directory-abbrev-alist + nil + "*Alist of abbreviations for file directories. +A list of elements of the form (FROM . TO), each meaning to replace +FROM with TO when it appears in a directory name. This replacement is +done when setting up the default directory of a newly visited file. +*Every* FROM string should start with `^'. + +Use this feature when you have directories which you normally refer to +via absolute symbolic links. Make TO the name of the link, and FROM +the name it is linked to.") + +(defconst automount-dir-prefix "^/tmp_mnt/" + "Regexp to match the automounter prefix in a directory name.") + +(defvar abbreviated-home-dir nil + "The the user's homedir abbreviated according to `directory-abbrev-list'.") + +;;; Autoloads + +(autoload 'diff "diff" "Diff two files." t) +(autoload 'diff-backup "diff" "Diff a file with its most recent backup.") + +;;; Functions which are subroutines in Emacs 19. + +;; Provide a non-working version of find-file-name-handler. +;; If you want it to work, require 'fn-handler. + +(or (fboundp 'find-file-name-handler) (fset 'find-file-name-handler 'ignore)) +(or (boundp 'file-name-handler-alist) (defvar file-name-handler-alist nil)) + +;; The name of buffer-flush-undo has changed in V19. +(fset 'buffer-disable-undo 'buffer-flush-undo) + +(defun current-time () + "Returns the number of seconds since midnight. +A poor man's version of the the function `current-time' in emacs 19." + (let ((string (current-time-string))) + (list + 0 + (+ (* 3600 (string-to-int (substring string 11 13))) + (* 60 (string-to-int (substring string 14 16))) + (string-to-int (substring string 17 19))) + 0))) + +;; call-process below may lose if filename starts with a `-', but I +;; fear not all mkdir or rmdir implementations understand `--'. + +(defun delete-directory (fn) + "Delete a directory. +This is a subr in Emacs 19." + (interactive + (list (read-file-name "Delete directory: " nil nil 'confirm))) + (setq fn (expand-file-name fn)) + (if (file-directory-p fn) + (call-process "rmdir" nil nil nil fn) + (error "Not a directory: %s" fn)) + (if (file-exists-p fn) + (error "Could not remove directory %s" fn))) + +(defun make-directory (dir &optional parents) + "Create the directory DIR and any nonexistent parent dirs." + (interactive "FMake directory: \nP") + (if (not parents) + (make-directory-internal dir) + (let ((dir (directory-file-name (expand-file-name dir))) + create-list) + (while (not (file-exists-p dir)) + (setq create-list (cons dir create-list) + dir (directory-file-name (file-name-directory dir)))) + (while create-list + (make-directory-internal (car create-list)) + (setq create-list (cdr create-list)))))) + +(defun make-directory-internal (fn) + ;; This is a subroutine in emacs 19. + (let* ((fn (expand-file-name fn)) + (handler (find-file-name-handler fn 'make-directory-internal))) + (if handler + (funcall handler 'make-directory-internal fn) + (setq fn (directory-file-name fn)) + (if (file-exists-p fn) + (error "Cannot make directory %s: file already exists" fn) + (call-process "mkdir" nil nil nil fn)) + (or (file-directory-p fn) + (error "Could not make directory %s" fn))))) + +(defun kill-new (string) + "Save STRING as if killed in a buffer." + (setq kill-ring (cons string kill-ring)) + (if (> (length kill-ring) kill-ring-max) + (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) + (setq kill-ring-yank-pointer kill-ring)) + +(defun insert-directory (file switches &optional wildcard full-directory-p) + "Insert directory listing for FILE, formatted according to SWITCHES. +Leaves point after the inserted text. +SWITCHES may be a string of options, or a list of strings. +Optional third arg WILDCARD means treat FILE as shell wildcard. +Optional fourth arg FULL-DIRECTORY-P means file is a directory and +switches do not contain `d', so that a full listing is expected. + +This works by running a directory listing program +whose name is in the variable `insert-directory-program'. +If WILDCARD, it also runs the shell specified by `shell-file-name'." + ;; We need the directory in order to find the right handler. + (let ((handler (find-file-name-handler (expand-file-name file) + 'insert-directory))) + (if handler + (funcall handler 'insert-directory file switches + wildcard full-directory-p) + (if (eq system-type 'vax-vms) + (vms-read-directory file switches (current-buffer)) + (if wildcard + ;; Run ls in the directory of the file pattern we asked for. + (let ((default-directory + (if (file-name-absolute-p file) + (file-name-directory file) + (file-name-directory (expand-file-name file)))) + (pattern (file-name-nondirectory file)) + (beg 0)) + ;; Quote some characters that have special meanings in shells; + ;; but don't quote the wildcards--we want them to be special. + ;; We also currently don't quote the quoting characters + ;; in case people want to use them explicitly to quote + ;; wildcard characters. + (while (string-match "[ \t\n;<>&|()#$]" pattern beg) + (setq pattern + (concat (substring pattern 0 (match-beginning 0)) + "\\" + (substring pattern (match-beginning 0))) + beg (1+ (match-end 0)))) + (call-process shell-file-name nil t nil + "-c" (concat insert-directory-program + " -d " + (if (stringp switches) + switches + (mapconcat 'identity switches " ")) + " " + pattern))) + ;; SunOS 4.1.3, SVr4 and others need the "." to list the + ;; directory if FILE is a symbolic link. + (apply 'call-process + insert-directory-program nil t nil + (let (list) + (if (listp switches) + (setq list switches) + (if (not (equal switches "")) + (progn + ;; Split the switches at any spaces + ;; so we can pass separate options as separate args. + (while (string-match " " switches) + (setq list (cons (substring switches 0 + (match-beginning 0)) + list) + switches (substring switches + (match-end 0)))) + (setq list (cons switches list))))) + (append list + (list + (if full-directory-p + (concat (file-name-as-directory file) ".") + file)))))))))) + +(defun file-local-copy (file) + "Copy the file FILE into a temporary file on this machine. +Returns the name of the local copy, or nil, if FILE is directly +accessible." + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-local-copy))) + ;; Does nothing, if no handler. + (if handler + (funcall handler 'file-local-copy file)))) + +(defun file-truename (filename) + "Return the truename of FILENAME, which should be absolute. +The truename of a file name is found by chasing symbolic links +both at the level of the file and at the level of the directories +containing it, until no links are left at any level." + (if (or (string= filename "~") + (and (string= (substring filename 0 1) "~") + (string-match "~[^/]*" filename))) + (progn + (setq filename (expand-file-name filename)) + (if (string= filename "") + (setq filename "/")))) + (let ((handler (find-file-name-handler filename 'file-truename))) + ;; For file name that has a special handler, call handler. + ;; This is so that ange-ftp can save time by doing a no-op. + (if handler + (funcall handler 'file-truename filename) + (let ((dir (file-name-directory filename)) + target dirfile file-name-handler-alist) + ;; Get the truename of the directory. + (setq dirfile (directory-file-name dir)) + ;; If these are equal, we have the (or a) root directory. + (or (string= dir dirfile) + (setq dir (file-name-as-directory (file-truename dirfile)))) + (if (equal ".." (file-name-nondirectory filename)) + (directory-file-name (file-name-directory + (directory-file-name dir))) + (if (equal "." (file-name-nondirectory filename)) + (directory-file-name dir) + ;; Put it back on the file name. + (setq filename (concat dir (file-name-nondirectory filename))) + ;; Is the file name the name of a link? + (setq target (file-symlink-p filename)) + (if target + ;; Yes => chase that link, then start all over + ;; since the link may point to a directory name that uses links. + ;; We can't safely use expand-file-name here + ;; since target might look like foo/../bar where foo + ;; is itself a link. Instead, we handle . and .. above. + (if (file-name-absolute-p target) + (file-truename target) + (file-truename (concat dir target))) + ;; No, we are done! + filename))))))) + +(defun generate-new-buffer-name (name) + "Return a string which is the name of no existing buffer based on +NAME. If there is no live buffer named NAME, return NAME. Otherwise, +modify name by appending `', incrementing NUMBER until an +unused name is found. Return that name." + (if (get-buffer name) + (let ((num 2) + attempt) + (while (progn + (setq attempt (concat name "<" (int-to-string num) ">")) + (get-buffer attempt)) + (setq num (1+ num))) + attempt) + name)) + +(defun abbreviate-file-name (filename) + "Return a version of FILENAME shortened using `directory-abbrev-alist'. +This also substitutes \"~\" for the user's home directory. +Type \\[describe-variable] directory-abbrev-alist RET for more information." + ;; Get rid of the prefixes added by the automounter. + (if (and (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + (let ((tail directory-abbrev-alist)) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (while tail + (if (string-match (car (car tail)) filename) + (setq filename + (concat (cdr (car tail)) (substring filename (match-end 0))))) + (setq tail (cdr tail))) + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + (or abbreviated-home-dir + (setq abbreviated-home-dir + (let ((abbreviated-home-dir "$foo")) + (concat "^" (abbreviate-file-name (expand-file-name "~")))))) + ;; If FILENAME starts with the abbreviated homedir, + ;; make it start with `~' instead. + (if (string-match abbreviated-home-dir filename) + (setq filename + (concat "~" + ;; If abbreviated-home-dir ends with a slash, + ;; don't remove the corresponding slash from + ;; filename. On MS-DOS and OS/2, you can have + ;; home directories like "g:/", in which it is + ;; important not to remove the slash. And what + ;; about poor root on Unix systems? + (if (eq ?/ (aref abbreviated-home-dir + (1- (length abbreviated-home-dir)))) + "/" + "") + (substring filename (match-end 0))))) + filename)) + +(defun file-newest-backup (filename) + "Return most recent backup file for FILENAME or nil if no backups exist." + (let* ((filename (expand-file-name filename)) + (file (file-name-nondirectory filename)) + (dir (file-name-directory filename)) + (comp (file-name-all-completions file dir)) + newest) + (while comp + (setq file (concat dir (car comp)) + comp (cdr comp)) + (if (and (backup-file-name-p file) + (or (null newest) (file-newer-than-file-p file newest))) + (setq newest file))) + newest)) + +;; This is used in various files. +;; The usage of bv-length is not very clean, +;; but I can't see a good alternative, +;; so as of now I am leaving it alone. +(defun backup-extract-version (fn) + "Given the name of a numeric backup file, return the backup number. +Uses the free variable `bv-length', whose value should be +the index in the name where the version number begins." + (if (and (string-match "[0-9]+~$" fn bv-length) + (= (match-beginning 0) bv-length)) + (string-to-int (substring fn bv-length -1)) + 0)) + +;; The standard V18 version of this function doesn't support +;; the arg KEEP-BACKUP-VERSION +(defun file-name-sans-versions (name &optional keep-backup-version) + "Return FILENAME sans backup versions or strings. +This is a separate procedure so your site-init or startup file can +redefine it. +If the optional argument KEEP-BACKUP-VERSION is non-nil, +we do not remove backup version numbers, only true file version numbers." + (let ((handler (find-file-name-handler name 'file-name-sans-versions))) + (if handler + (funcall handler 'file-name-sans-versions name keep-backup-version) + (substring name 0 + (if (eq system-type 'vax-vms) + ;; VMS version number is (a) semicolon, optional + ;; sign, zero or more digits or (b) period, option + ;; sign, zero or more digits, provided this is the + ;; second period encountered outside of the + ;; device/directory part of the file name. + (or (string-match ";[-+]?[0-9]*\\'" name) + (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'" + name) + (match-beginning 1)) + (length name)) + (if keep-backup-version + (length name) + (or (string-match "\\.~[0-9]+~\\'" name) + (string-match "~\\'" name) + (length name)))))))) + +(defun member (x y) + "Like memq, but uses `equal' for comparison. +This is a subr in Emacs 19." + (while (and y (not (equal x (car y)))) + (setq y (cdr y))) + y) + +(defun compiled-function-p (x) + "Emacs 18 doesn't have these." + nil) + +;; punt -- this will at least allow handlers to work for this. +(defun set-visited-file-modtime (&optional time) + (error "set-visited-file-modtime not defined in emacs 18.")) + +(defun add-hook (hook function &optional append) + "Add to the value of HOOK the function FUNCTION. +FUNCTION is not added if already present. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. + +HOOK should be a symbol, and FUNCTION may be any valid function. If +HOOK is void, it is first set to nil. If HOOK's value is a single +function, it is changed to a list of functions." + (or (boundp hook) (set hook nil)) + ;; If the hook value is a single function, turn it into a list. + (let ((old (symbol-value hook))) + (if (or (not (listp old)) (eq (car old) 'lambda)) + (set hook (list old)))) + (or (if (consp function) + ;; Clever way to tell whether a given lambda-expression + ;; is equal to anything in the hook. + (let ((tail (assoc (cdr function) (symbol-value hook)))) + (equal function tail)) + (memq function (symbol-value hook))) + (set hook + (if append + (nconc (symbol-value hook) (list function)) + (cons function (symbol-value hook)))))) + +;;; after-save.el (Now part of files.el in Gnu Emacs V19) + +;;; Copyright (C) 1990 Roland McGrath +;;; + +(or (fboundp 'real-save-buffer) + (fset 'real-save-buffer (symbol-function 'save-buffer))) + +(defvar after-save-hook nil + "A function or list of functions to be run after saving the current buffer.") + +(defun save-buffer (&optional args) + "Save the current buffer, and then run `after-save-buffer-hook'. +The hooks are only run if the buffer was actually written. +For more documentation, do \\[describe-function] real-save-buffer RET." + (interactive "p") + (let ((modp (buffer-modified-p))) + (real-save-buffer args) + (if modp + (run-hooks 'after-save-hook)))) + +;;; end of after-save + +;;;; +;;;; Correcting for V18 bugs, and hacking around stupidities. +;;;; + +;; The 18.57 version has a bug that causes C-x C-v RET (which usually +;; re-visits the current buffer) to fail on dired buffers. +;; Only the last statement was changed to avoid killing the current +;; buffer. +(defun find-alternate-file (filename) + "Find file FILENAME, select its buffer, kill previous buffer. +If the current buffer now contains an empty file that you just visited +\(presumably by mistake), use this command to visit the file you really want." + (interactive "FFind alternate file: ") + (and (buffer-modified-p) + (not buffer-read-only) + (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? " + (buffer-name)))) + (error "Aborted")) + (let ((obuf (current-buffer)) + (ofile buffer-file-name) + (oname (buffer-name))) + (rename-buffer " **lose**") + (setq buffer-file-name nil) + (unwind-protect + (progn + (unlock-buffer) + (find-file filename)) + (cond ((eq obuf (current-buffer)) + (setq buffer-file-name ofile) + (lock-buffer) + (rename-buffer oname)))) + (or (eq (current-buffer) obuf) + (kill-buffer obuf)))) + +;; At least in Emacs 18.55 this defvar has been forgotten to be copied +;; from lpr.el into loaddefs.el + +(defvar lpr-command (if (eq system-type 'usg-unix-v) + "lp" "lpr") + "Shell command for printing a file") + + +;; buffer-disable-undo used to be called buffer-flush-undo in Emacs +;; 18.55: +(or (fboundp 'buffer-disable-undo) + (fset 'buffer-disable-undo 'buffer-flush-undo)) + +;;; end of emacs-19.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/fixup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/fixup.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,38 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: fixup.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Fix up the load path for batch byte compilation of efs. +;; Author: Andy Norman, Dawn +;; Created: Sat Jan 30 00:21:33 1993 +;; Modified: Fri Sep 16 20:01:50 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(setq load-path + (append (list (substitute-in-file-name "$CWD") + (substitute-in-file-name "$BDIR") + (substitute-in-file-name "$VMDIR") + ) + load-path)) + +(setq byte-compile-warnings t) + +;; If the V18 btye-compiler is being used, this won't be around, so don't +;; complain if we can't find it. +(load "bytecomp-runtime" t t) + +(load "bytecomp" nil t) + +;; It seems efs causes the standard byte compiler some grief here. +(setq max-lisp-eval-depth (* 2 max-lisp-eval-depth)) + +;; If the user has the standard dired loaded, having dired +;; featurep will cause efs-dired.el to attempt to do overloads. +(delq 'dired features) + +;;; end of fixup.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/efs/fn-handler.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/fn-handler.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,656 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: fn-handler.el +;; Description: enhanced file-name-handler-alist support for pre-19.23 Emacs +;; Author: Sandy Rutherford +;; Created: Sat Mar 19 00:50:10 1994 by sandy on ibm550 +;; Modified: Tue Sep 13 20:59:19 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; One of the problems with the file-name-handler-alist, is that when +;;; a handler gets called, and it has nothing to do for that function, +;;; the usual procedure is to remove the handler from the alist, and +;;; re-call the function. This is necessary to avoid an infinite +;;; recursion. However, if the function calling +;;; find-file-name-handler is not a primitive, there may be other lisp +;;; functions inside of it for which the handler does have some +;;; special actions specified. They won't run, because the let-bound +;;; value of file-name-handler-alist doesn't contain the handler. +;;; +;;; This problem was solved in Emacs 19.23 with the variables +;;; inhibit-file-name-handlers and inhibit-file-name-operation +;;; This file provides this solution to older versions of emacs. + + +(provide 'fn-handler) +(require 'efs-ovwrt) + +(or (boundp 'file-name-handler-alist) + (defvar file-name-handler-alist nil + "Association list of regexps for special file names and handlers.")) + +(defvar inhibit-file-name-handlers nil + "List of handlers \(symbols\) to be avoided by `find-file-name-handler'.") + +(defvar inhibit-file-name-operation nil + "Defines to which operation `inhibit-file-name-handlers applies' +Must be a synbol.") + +(defun find-file-name-handler (filename &optional operation) + "Return FILENAME1's handler function, if its syntax is handled specially. +Does not return handlers in `inhibit-file-name-handlers' list. +If there is no handler for FILENAME1, searches for one for FILENAME2. +Returns nil, if there is no handler for either file name. +A file name is handles specially if one of the regular expressions in +`file-name-handler-alist' matches it." + (let ((match-data (match-data))) + (unwind-protect + (catch 'handler + (mapcar (function + (lambda (x) + (and + (not + (and + (or (null operation) + (eq operation inhibit-file-name-operation)) + (memq (cdr x) inhibit-file-name-handlers))) + (string-match (car x) filename) + (throw 'handler (cdr x))))) + file-name-handler-alist) + nil) + (store-match-data match-data)))) + +;;; Overloads to supply the file-name-handler-alist + +(defun fn-handler-insert-file-contents (filename &optional visit &rest args) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'insert-file-contents))) + (if handler + (apply handler 'insert-file-contents filename visit args) + (let (file-name-handler-alist) + (apply 'fn-handler-real-insert-file-contents filename visit args))))) + +(efs-overwrite-fn "fn-handler" 'insert-file-contents + 'fn-handler-insert-file-contents) + +(defun fn-handler-directory-files (directory &optional full match &rest nosort) + "Documented as original." + (let ((handler (find-file-name-handler directory 'directory-files))) + (if handler + (apply handler 'directory-files directory full match nosort) + (let (file-name-handler-alist) + (apply 'fn-handler-real-directory-files + directory full match nosort))))) + +(efs-overwrite-fn "fn-handler" 'directory-files 'fn-handler-directory-files) + +(defun fn-handler-list-directory (dirname &optional verbose) + "Documented as original." + (interactive (let ((pfx current-prefix-arg)) + (list (read-file-name (if pfx "List directory (verbose): " + "List directory (brief): ") + nil default-directory nil) + pfx))) + (let ((handler (find-file-name-handler dirname 'list-directory))) + (if handler + (funcall handler 'list-directory dirname verbose) + (let (file-name-handler-alist) + (fn-handler-real-list-directory dirname verbose))))) + +(efs-overwrite-fn "fn-handler" 'list-directory 'fn-handler-list-directory) + +(defun fn-handler-file-directory-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-directory-p))) + (if handler + (funcall handler 'file-directory-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-directory-p filename))))) + +(efs-overwrite-fn "fn-handler" ' file-directory-p 'fn-handler-file-directory-p) + +(defun fn-handler-file-writable-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-writable-p))) + (if handler + (funcall handler 'file-writable-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-writable-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-writable-p 'fn-handler-file-writable-p) + +(defun fn-handler-file-readable-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-readable-p))) + (if handler + (funcall handler 'file-readable-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-readable-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-readable-p 'fn-handler-file-readable-p) + +(defun fn-handler-file-symlink-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-symlink-p))) + (if handler + (funcall handler 'file-symlink-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-symlink-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-symlink-p 'fn-handler-file-symlink-p) + +(defun fn-handler-delete-file (file) + "Documented as original" + (interactive (list (read-file-name "Delete-file: " nil nil t))) + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'delete-file))) + (if handler + (funcall handler 'delete-file file) + (let (file-name-handler-alist) + (fn-handler-real-delete-file file))))) + +(efs-overwrite-fn "fn-handler" 'delete-file 'fn-handler-delete-file) + +(defun fn-handler-file-exists-p (filename) + "Documented as original" + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-exists-p))) + (if handler + (funcall handler 'file-exists-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-exists-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-exists-p 'fn-handler-file-exists-p) + +(defun fn-handler-write-region (start end filename &optional append visit) + "Documented as original" + ;; Use read-file-name, rather then interactive spec, + ;; to make it easier to get decent initial contents in the minibuffer. + (interactive + (progn + (or (mark) (error "The mark is not set now.")) + (list (min (point) (mark)) + (max (point) (mark)) + (read-file-name "Write region to file: ")))) + (let* ((filename (expand-file-name filename)) + (handler (or (find-file-name-handler filename 'write-region) + (and (stringp visit) + (find-file-name-handler (expand-file-name visit) + 'write-region))))) + (if handler + (funcall handler 'write-region start end filename append visit) + (let (file-name-handler-alist) + (fn-handler-real-write-region start end filename append visit))))) + +(efs-overwrite-fn "fn-handler" 'write-region + 'fn-handler-write-region) + +(defun fn-handler-verify-visited-file-modtime (buffer) + "Documented as original" + (let* ((file (buffer-file-name buffer)) + (handler (and file (find-file-name-handler + file + 'verify-visited-file-modtime)))) + (if handler + (funcall handler 'verify-visited-file-modtime buffer) + (let (file-name-handler-alist) + (fn-handler-real-verify-visited-file-modtime buffer))))) + +(efs-overwrite-fn "fn-handler" 'verify-visited-file-modtime + 'fn-handler-verify-visited-file-modtime) + +(defun fn-handler-backup-buffer () + "Documented as original" + (let ((handler (and buffer-file-name + (find-file-name-handler buffer-file-name + 'backup-buffer)))) + (if handler + (funcall handler 'backup-buffer) + ;; Don't let-bind file-name-handler-alist to nil, as backup-buffer + ;; is a lisp function and I want handlers to be available inside it. + (fn-handler-real-backup-buffer)))) + +(efs-overwrite-fn "fn-handler" 'backup-buffer 'fn-handler-backup-buffer) + +(defun fn-handler-copy-file (filename newname &optional ok-if-already-exists + keep-date) + "Documented as original" + ;; handler for filename takes precedence over the handler for newname. + (interactive + (let* ((from (read-file-name "Copy file: " nil nil t)) + (to (read-file-name (format "Copy %s to: " (abbreviate-file-name + from))))) + (list from to 0 current-prefix-arg))) + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler filename 'copy-file) + (find-file-name-handler newname 'copy-file)))) + (if handler + ;; Using the NOWAIT arg is a bit risky for other users of the + ;; handler-alist + (funcall handler 'copy-file filename newname ok-if-already-exists + keep-date) + (let (file-name-handler-alist) + (fn-handler-real-copy-file filename newname ok-if-already-exists + keep-date))))) + +(efs-overwrite-fn "fn-handler" 'copy-file 'fn-handler-copy-file) + +(defun fn-handler-file-newer-than-file-p (file1 file2) + "Documented as original" + ;; The handler for file2 takes precedence over the handler for file1. + (let* ((file1 (expand-file-name file1)) + (file2 (expand-file-name file2)) + (handler (or (find-file-name-handler file2 'file-newer-than-file-p) + (find-file-name-handler file1 'file-newer-than-file-p)))) + (if handler + (funcall handler 'file-newer-than-file-p file1 file2) + (let (file-name-handler-alist) + (fn-handler-real-file-newer-than-file-p file1 file2))))) + +(efs-overwrite-fn "fn-handler" 'file-newer-than-file-p + 'fn-handler-file-newer-than-file-p) + +(defun fn-handler-file-attributes (file) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-attributes))) + (if handler + (funcall handler 'file-attributes file) + (let (file-name-handler-alist) + (fn-handler-real-file-attributes file))))) + +(efs-overwrite-fn "fn-handler" 'file-attributes 'fn-handler-file-attributes) + +(defun fn-handler-file-name-directory (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'file-name-directory))) + (if handler + (funcall handler 'file-name-directory file) + (let (file-name-handler-alist) + (fn-handler-real-file-name-directory file))))) + +(efs-overwrite-fn "fn-handler" 'file-name-directory + 'fn-handler-file-name-directory) + +(defun fn-handler-rename-file (filename newname &optional ok-if-already-exists) + "Documented as original" + (interactive + (let* ((from (read-file-name "Rename file: " nil nil t)) + (to (read-file-name (format "Rename %s to: " (abbreviate-file-name + from))))) + (list from to 0))) + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler filename 'rename-file) + (find-file-name-handler newname 'rename-file)))) + (if handler + (funcall handler 'rename-file filename newname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-rename-file filename newname ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'rename-file 'fn-handler-rename-file) + +(defun fn-handler-insert-directory (file switches + &optional wildcard full-directory-p) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'insert-directory))) + (if handler + (funcall handler 'insert-directory file switches wildcard + full-directory-p) + (let (file-name-handler-alist) + (fn-handler-real-insert-directory file switches wildcard + full-directory-p))))) + +(efs-overwrite-fn "fn-handler" 'insert-directory 'fn-handler-insert-directory) + +(defun fn-handler-set-visited-file-modtime (&optional time) + "Sets the buffer's record of file modtime to the modtime of buffer-file-name. +With optional TIME, sets the modtime to TIME. This is an emacs 19 function. +In emacs 18, efs will make this work for remote files only." + (if buffer-file-name + (let ((handler (find-file-name-handler buffer-file-name + 'set-visited-file-modtime))) + (if handler + (funcall handler 'set-visited-file-modtime time) + (let (file-name-handler-alist) + (fn-handler-real-set-visited-file-modtime time)))))) + +(efs-overwrite-fn "fn-handler" 'set-visited-file-modtime + 'fn-handler-set-visited-file-modtime) + +(defun fn-handler-file-name-nondirectory (name) + "Documented as original" + (let ((handler (find-file-name-handler name 'file-name-nondirectory))) + (if handler + (funcall handler 'file-name-nondirectory name) + (let (file-name-handler-alist) + (fn-handler-real-file-name-nondirectory name))))) + +(efs-overwrite-fn "fn-handler" 'file-name-nondirectory + 'fn-handler-file-name-nondirectory) + +(defun fn-handler-file-name-as-directory (name) + "Documented as original" + (let ((handler (find-file-name-handler name 'file-name-as-directory))) + (if handler + (funcall handler 'file-name-as-directory name) + (let (file-name-handler-alist) + (fn-handler-real-file-name-as-directory name))))) + +(efs-overwrite-fn "fn-handler" 'file-name-as-directory + 'fn-handler-file-name-as-directory) + +(defun fn-handler-directory-file-name (directory) + "Documented as original" + (let ((handler (find-file-name-handler directory 'directory-file-name))) + (if handler + (funcall handler 'directory-file-name directory) + (let (file-name-handler-alist) + (fn-handler-real-directory-file-name directory))))) + +(efs-overwrite-fn "fn-handler" 'directory-file-name + 'fn-handler-directory-file-name) + +(defun fn-handler-get-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'get-file-buffer))) + (if handler + (funcall handler 'get-file-buffer file) + (let (file-name-handler-alist) + (fn-handler-real-get-file-buffer file))))) + +(efs-overwrite-fn "fn-handler" 'get-file-buffer 'fn-handler-get-file-buffer) + +(defun fn-handler-create-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'create-file-buffer))) + (if handler + (funcall handler 'create-file-buffer file) + (let (file-name-handler-alist) + (fn-handler-real-create-file-buffer file))))) + +(efs-overwrite-fn "fn-handler" 'create-file-buffer + 'fn-handler-create-file-buffer) + +(defun fn-handler-set-file-modes (file mode) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'set-file-modes))) + (if handler + (funcall handler 'set-file-modes file mode) + (let (file-name-handler-alist) + (fn-handler-real-set-file-modes file mode))))) + +(efs-overwrite-fn "fn-handler" 'set-file-modes 'fn-handler-set-file-modes) + +(defun fn-handler-file-modes (file) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-modes))) + (if handler + (funcall handler 'file-modes file) + (let (file-name-handler-alist) + (fn-handler-real-file-modes file))))) + +(efs-overwrite-fn "fn-handler" 'file-modes 'fn-handler-file-modes) + +(if (string-match emacs-version "Lucid") + + (progn + (defun fn-handler-abbreviate-file-name (filename &optional hack-homedir) + "Documented as original" + (let ((handler (find-file-name-handler filename + 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename hack-homedir) + (let (file-name-handler-alist) + (fn-handler-real-abbreviate-file-name filename hack-homedir)))))) + + (defun fn-handler-abbreviate-file-name (filename) + "Documented as original" + (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename) + (let (file-name-handler-alist) + (fn-handler-real-abbreviate-file-name filename)))))) + +(efs-overwrite-fn "fn-handler" 'abbreviate-file-name + 'fn-handler-abbreviate-file-name) + +(defun fn-handler-file-name-sans-versions (filename + &optional keep-backup-version) + "Documented as original" + (let ((handler (find-file-name-handler filename 'file-name-sans-versions))) + (if handler + (funcall handler 'file-name-sans-versions filename + keep-backup-version) + (let (file-name-handler-alist) + (fn-handler-real-file-name-sans-versions filename + keep-backup-version))))) + +(efs-overwrite-fn "fn-handler" 'file-name-sans-versions + 'fn-handler-file-name-sans-versions) + +(if (fboundp 'make-directory-internal) ; not defined in lemacs 19.[67] + (progn + (defun fn-handler-make-directory-internal (dirname) + "Documented as original" + (let* ((dirname (expand-file-name dirname)) + (handler (find-file-name-handler dirname + 'make-directory-internal))) + (if handler + (funcall handler 'make-directory-internal dirname) + (let (file-name-handler-alist) + (fn-handler-real-make-directory-internal dirname))))) + + (efs-overwrite-fn "fn-handler" 'make-directory-internal + 'fn-handler-make-directory-internal))) + +(defun fn-handler-delete-directory (dirname) + "Documented as original" + (let* ((dirname (expand-file-name dirname)) + (handler (find-file-name-handler dirname 'delete-directory))) + (if handler + (funcall handler 'delete-directory dirname) + (let (file-name-handler-alist) + (fn-handler-real-delete-directory dirname))))) + +(efs-overwrite-fn "fn-handler" 'delete-directory 'fn-handler-delete-directory) + +(defun fn-handler-make-symbolic-link (target linkname + &optional ok-if-already-exists) + "Documented as original" + (interactive + (let (target) + (list + (setq target (read-string "Make symbolic link to file: ")) + (read-file-name (format "Make symbolic link to file %s: " target)) + 0))) + (let* ((linkname (expand-file-name linkname)) + (handler (or (find-file-name-handler linkname 'make-symbolic-link) + (find-file-name-handler target 'make-symbolic-link)))) + (if handler + (funcall handler 'make-symbolic-link + target linkname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-make-symbolic-link target linkname + ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'make-symbolic-link + 'fn-handler-make-symbolic-link) + +(defun fn-handler-add-name-to-file (file newname &optional + ok-if-already-exists) + "Documented as original" + (interactive + (let (file) + (list + (setq file (read-file-name "Add name to file: " nil nil t)) + (read-file-name (format "Name to add to %s: " file)) + 0))) + (let* ((file (expand-file-name file)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler newname 'add-name-to-file) + (find-file-name-handler file 'add-name-to-file)))) + (if handler + (funcall handler 'add-name-to-file file newname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-add-name-to-file file newname + ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'add-name-to-file 'fn-handler-add-name-to-file) + +(defun fn-handler-recover-file (file) + "Documented as original" + (interactive "FRecover file: ") + (let* ((file (expand-file-name file)) + (handler (or (find-file-name-handler file 'recover-file) + (find-file-name-handler (let ((buffer-file-name file)) + (make-auto-save-file-name)) + 'recover-file)))) + (if handler + (funcall handler 'recover-file file) + (let (file-name-handler-alist) + (fn-handler-real-recover-file file))))) + +(efs-overwrite-fn "fn-handler" 'recover-file 'fn-handler-recover-file) + +(defun fn-handler-file-name-completion (file dir) + "Documented as original." + (let* ((dir (expand-file-name dir)) + (handler (find-file-name-handler dir 'file-name-completion))) + (if handler + (funcall handler 'file-name-completion file dir) + (let (file-name-handler-alist) + (fn-handler-real-file-name-completion file dir))))) + +(efs-overwrite-fn "fn-handler" 'file-name-completion + 'fn-handler-file-name-completion) + +(defun fn-handler-file-name-all-completions (file dir) + "Documented as original." + (let* ((dir (expand-file-name dir)) + (handler (find-file-name-handler dir 'file-name-all-completions))) + (if handler + (funcall handler 'file-name-all-completions file dir) + (let (file-name-handler-alist) + (fn-handler-real-file-name-all-completions file dir))))) + +(efs-overwrite-fn "fn-handler" 'file-name-all-completions + 'fn-handler-file-name-all-completions) + +(if (fboundp 'file-truename) + (progn + (defun fn-handler-file-truename (filename) + "Documented as original" + (let* ((fn (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-truename))) + (if handler + (funcall handler 'file-truename filename) + (let (file-name-handler-alist) + (fn-handler-real-file-truename filename))))) + (efs-overwrite-fn "fn-handler" 'file-truename + 'fn-handler-file-truename))) + +(if (fboundp 'unhandled-file-name-directory) + (progn + (defun fn-handler-unhandled-file-name-directory (filename) + "Documented as original" + (let ((handler (find-file-name-handler + filename 'unhandled-file-name-directory))) + (if handler + (funcall handler 'unhandled-file-name-directory filename) + (let (file-name-handler-alist) + (fn-handler-real-unhandled-file-name-directory filename))))) + + (efs-overwrite-fn "fn-handler" 'unhandled-file-name-directory + 'fn-handler-unhandled-file-name-directory))) + + +;; We don't need the file-name-handler-alist for these. Inhibit it to +;; avoid an infinite recursion. Hope that this doesn't step +;; on any other packages' toes. +(defun fn-handler-expand-file-name (filename &optional default) + "Documented as original." + (let (file-name-handler-alist) + (fn-handler-real-expand-file-name filename default))) + +(efs-overwrite-fn "fn-handler" 'expand-file-name 'fn-handler-expand-file-name) + +(defun fn-handler-substitute-in-file-name (filename) + "Documented as original." + (let ((handler (find-file-name-handler filename 'substitute-in-file-name))) + (if handler + (funcall handler 'substitute-in-file-name filename) + (let (file-name-handler-alist) + (fn-handler-real-substitute-in-file-name filename))))) + +(efs-overwrite-fn "fn-handler" 'substitute-in-file-name + 'fn-handler-substitute-in-file-name) + +(if (fboundp 'file-executable-p) + (progn + (defun fn-handler-file-executable-p (file) + (let ((handler (find-file-name-handler file 'file-executable-p))) + (if handler + (funcall handler 'file-executable-p file) + (let (file-name-handler-alist) + (fn-handler-real-file-executable-p file))))) + (efs-overwrite-fn "fn-handler" 'file-executable-p + 'fn-handler-file-executable-p))) + +(if (fboundp 'file-accessible-directory-p) + (progn + (defun fn-handler-file-accessible-directory-p (file) + (let ((handler (find-file-name-handler file + 'file-accessible-directory-p))) + (if handler + (funcall handler 'file-accessible-directory-p file) + (let (file-name-handler-alist) + (fn-handler-real-file-accessible-directory-p file))))) + (efs-overwrite-fn "fn-handler" 'file-accessible-directory-p + 'fn-handler-file-accessible-directory-p))) + +(defun fn-handler-load (file &optional noerror nomessage nosuffix) + (let ((handler (find-file-name-handler file 'load))) + (if handler + (funcall handler 'load file noerror nomessage nosuffix) + (let (file-name-handler-alist) + (fn-handler-real-load file noerror nomessage nosuffix))))) + +(efs-overwrite-fn "fn-handler" 'load 'fn-handler-load) + +;; We don't need file-name-handlers for do-auto-save. +;; If it does try to access them there is a risk of an infinite recursion. +(defun fn-handler-do-auto-save (&rest args) + "Documented as original." + (let (file-name-handler-alist) + (apply 'fn-handler-real-do-auto-save args))) + +(efs-overwrite-fn "fn-handler" 'do-auto-save 'fn-handler-do-auto-save) + +(if (fboundp 'vc-registered) + (progn + (defun fn-handler-vc-registered (file) + "Documented as original." + (let ((handler (find-file-name-handler file 'vc-registered))) + (if handler + (funcall handler 'vc-registered file) + (let (file-name-handler-alist) + (fn-handler-real-vc-registered file))))) + + (efs-overwrite-fn "fn-handler" 'vc-registered + 'fn-handler-vc-registered))) + +;;; end of fn-handler.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/egg/egg-jsymbol.el --- a/lisp/egg/egg-jsymbol.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/egg/egg-jsymbol.el Mon Aug 13 09:13:56 2007 +0200 @@ -822,10 +822,8 @@ (let ((ten 126)) (while (< 32 ten) (setq result (cons - (let ((str (make-string 3 0))) - (aset str 0 lc-jp) - (aset str 1 (+ 128 ku)) - (aset str 2 (+ 128 ten)) + (let ((str (make-string 1 0))) + (aset str 0 (make-char (find-charset 'japanese-jisx0208) ku ten)) (cons str str)) result)) (setq ten (1- ten)))) @@ -838,10 +836,8 @@ (let ((ten 126)) (while (<= 33 ten) (setq result (cons - (let ((str (make-string 3 0))) - (aset str 0 lc-jp) - (aset str 1 (+ 128 ku)) - (aset str 2 (+ 128 ten)) + (let ((str (make-string 1 0))) + (aset str 0 (make-char (find-charset 'japanese-jisx0208) ku ten)) (cons str str)) result)) (setq ten (1- ten)))) @@ -854,10 +850,8 @@ (let ((ten 126)) (while (<= 33 ten) (setq result (cons - (let ((str (make-string 3 0))) ; by T.Shingu - (aset str 0 lc-jp) - (aset str 1 (+ 128 ku)) - (aset str 2 (+ 128 ten)) + (let ((str (make-string 1 0))) ; by T.Shingu + (aset str 0 (make-char (find-charset 'japanese-jisx0208) ku ten)) (cons str str)) result)) (setq ten (1- ten)))) @@ -870,10 +864,8 @@ (let ((ten 126)) (while (<= 33 ten) (setq result (cons - (let ((str (make-string 3 0))) - (aset str 0 lc-jp2) - (aset str 1 (+ 128 ku)) - (aset str 2 (+ 128 ten)) + (let ((str (make-string 1 0))) + (aset str 0 (make-char (find-charset 'japanese-jisx0212) ku ten)) (cons str str)) result)) (setq ten (1- ten)))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/egg/egg-wnn.el --- a/lisp/egg/egg-wnn.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/egg/egg-wnn.el Mon Aug 13 09:13:56 2007 +0200 @@ -35,6 +35,8 @@ ;;; $B=$@5%a%b(B +;;; 97/2/4 Modified for use with XEmacs by J.Hein +;;; (mostly changes regarding extents and markers) ;;; 94/2/3 kWnn support by H.Kuribayashi ;;; 93/11/24 henkan-select-kouho: bug fixed ;;; 93/7/22 hinsi-from-menu updated @@ -92,19 +94,19 @@ (defvar egg:*sho-bunsetu-face* nil "*$B>.J8@aI=<($KMQ$$$k(B face $B$^$?$O(B nil") (make-variable-buffer-local - (defvar egg:*sho-bunsetu-overlay* nil "$B>.J8@a$NI=<($K;H$&(B overlay")) + (defvar egg:*sho-bunsetu-extent* nil "$B>.J8@a$NI=<($K;H$&(B extent")) (defvar egg:*sho-bunsetu-kugiri* "-" "*$B>.J8@a$N6h@Z$j$r<($9J8;zNs(B") (defvar egg:*dai-bunsetu-face* nil "*$BBgJ8@aI=<($KMQ$$$k(B face $B$^$?$O(B nil") (make-variable-buffer-local - (defvar egg:*dai-bunsetu-overlay* nil "$BBgJ8@a$NI=<($K;H$&(B overlay")) + (defvar egg:*dai-bunsetu-extent* nil "$BBgJ8@a$NI=<($K;H$&(B extent")) (defvar egg:*dai-bunsetu-kugiri* " " "*$BBgJ8@a$N6h@Z$j$r<($9J8;zNs(B") (defvar egg:*henkan-face* nil "*$BJQ49NN0h$rI=<($9$k(B face $B$^$?$O(B nil") (make-variable-buffer-local - (defvar egg:*henkan-overlay* nil "$BJQ49NN0h$NI=<($K;H$&(B overlay")) + (defvar egg:*henkan-extent* nil "$BJQ49NN0h$NI=<($K;H$&(B extent")) (defvar egg:*henkan-open* "|" "*$BJQ49$N;OE@$r<($9J8;zNs(B") (defvar egg:*henkan-close* "|" "*$BJQ49$N=*E@$r<($9J8;zNs(B") @@ -453,6 +455,8 @@ (if (null (wnn-server-fuzokugo-set (substitute-in-file-name ffile))) (egg:error (wnn-server-get-msg)))) +;; ###jhod Currently very broken. Needs to be rewritten for the new +;; wnn-server-set-param (defun set-wnn-param (&rest param) (interactive) ; (open-wnn-if-disconnected) @@ -776,21 +780,22 @@ ;;;; (defun egg:henkan-face-on () - ;; Make an overlay if henkan overlay does not exist. - ;; Move henkan overlay to henkan region. + ;; Make an extent if henkan extent does not exist. + ;; Move henkan extent to henkan region. (if egg:*henkan-face* (progn - (if (overlayp egg:*henkan-overlay*) + (if (extentp egg:*henkan-extent*) nil - (setq egg:*henkan-overlay* (make-overlay 1 1 nil t)) - (overlay-put egg:*henkan-overlay* 'face egg:*henkan-face*)) - (move-overlay egg:*henkan-overlay* egg:*region-start* egg:*region-end*)))) + ;; ###jhod this was a 'point-type' overlay + (setq egg:*henkan-extent* (make-extent 1 1)) + (set-extent-property egg:*henkan-extent* 'face egg:*henkan-face*)) + (set-extent-endpoints egg:*henkan-extent* egg:*region-start* egg:*region-end*)))) (defun egg:henkan-face-off () - ;; detach henkan overlay from the current buffer. + ;; detach henkan extent from the current buffer. (and egg:*henkan-face* - (overlayp egg:*henkan-overlay*) - (delete-overlay egg:*henkan-overlay*) )) + (extentp egg:*henkan-extent*) + (delete-extent egg:*henkan-extent*) )) (defun henkan-region (start end) @@ -837,7 +842,7 @@ (or (markerp egg:*region-start*) (setq egg:*region-start* (make-marker))) (or (markerp egg:*region-end*) - (setq egg:*region-end* (set-marker-type (make-marker) t))) + (setq egg:*region-end* (set-marker-insertion-type (make-marker) t))) (if (null (marker-position egg:*region-start*)) (progn ;;;(setq egg:*global-map-backup* (current-global-map)) @@ -974,22 +979,22 @@ (if (or (null henkan-face) (memq henkan-face (face-list))) (progn (setq egg:*henkan-face* henkan-face) - (if (overlayp egg:*henkan-overlay*) - (overlay-put egg:*henkan-overlay* 'face egg:*henkan-face*))) + (if (extentp egg:*henkan-extent*) + (set-extent-property egg:*henkan-extent* 'face egg:*henkan-face*))) (egg:error "Wrong type of arguments(henkan-face): %s" henkan-face)) (if (or (null dai-bunsetu-face) (memq dai-bunsetu-face (face-list))) (progn (setq egg:*dai-bunsetu-face* dai-bunsetu-face) - (if (overlayp egg:*dai-bunsetu-overlay*) - (overlay-put egg:*dai-bunsetu-overlay* 'face egg:*dai-bunsetu-face*))) + (if (extentp egg:*dai-bunsetu-extent*) + (set-extent-property egg:*dai-bunsetu-extent* 'face egg:*dai-bunsetu-face*))) (egg:error "Wrong type of arguments(dai-bunsetu-face): %s" dai-bunsetu-face)) (if (or (null sho-bunsetu-face) (memq sho-bunsetu-face (face-list))) (progn (setq egg:*sho-bunsetu-face* sho-bunsetu-face) - (if (overlayp egg:*sho-bunsetu-overlay*) - (overlay-put egg:*sho-bunsetu-overlay* 'face egg:*sho-bunsetu-face*))) + (if (extentp egg:*sho-bunsetu-extent*) + (set-extent-property egg:*sho-bunsetu-extent* 'face egg:*sho-bunsetu-face*))) (egg:error "Wrong type of arguments(sho-bunsetu-face): %s" sho-bunsetu-face)) ) @@ -1123,55 +1128,60 @@ ) (defun egg:bunsetu-face-on () - ;; make dai-bunsetu overlay and sho-bunsetu overlay if they do not exist. - ;; put thier faces to overlays and move them to each bunsetu. + ;; make dai-bunsetu extent and sho-bunsetu extent if they do not exist. + ;; put thier faces to extents and move them to each bunsetu. (let* ((bunsetu-begin *bunsetu-number*) (bunsetu-end) (bunsetu-suu (wnn-server-bunsetu-suu))) ; dai bunsetu (if egg:*dai-bunsetu-face* (progn - (if (overlayp egg:*dai-bunsetu-overlay*) + (if (extentp egg:*dai-bunsetu-extent*) nil - (setq egg:*dai-bunsetu-overlay* (make-overlay 1 1)) - (overlay-put egg:*dai-bunsetu-overlay* 'face egg:*dai-bunsetu-face*)) + (setq egg:*dai-bunsetu-extent* (make-extent 1 1)) + (set-extent-property egg:*dai-bunsetu-extent* 'face egg:*dai-bunsetu-face*)) (setq bunsetu-end (wnn-server-dai-end *bunsetu-number*)) (while (not (wnn-server-dai-top bunsetu-begin)) (setq bunsetu-begin (1- bunsetu-begin))) - (move-overlay egg:*dai-bunsetu-overlay* + (set-extent-endpoints egg:*dai-bunsetu-extent* (bunsetu-position bunsetu-begin) (+ (bunsetu-position (1- bunsetu-end)) (length (bunsetu-kanji (1- bunsetu-end))))))) ; sho bunsetu (if egg:*sho-bunsetu-face* (progn - (if (overlayp egg:*sho-bunsetu-overlay*) + (if (extentp egg:*sho-bunsetu-extent*) nil - (setq egg:*sho-bunsetu-overlay* (make-overlay 1 1)) - (overlay-put egg:*sho-bunsetu-overlay* 'face egg:*sho-bunsetu-face*)) + (setq egg:*sho-bunsetu-extent* (make-extent 1 1)) + (set-extent-property egg:*sho-bunsetu-extent* 'face egg:*sho-bunsetu-face*)) (setq bunsetu-end (1+ *bunsetu-number*)) - (move-overlay egg:*sho-bunsetu-overlay* + (set-extent-endpoints egg:*sho-bunsetu-extent* (let ((point (bunsetu-position *bunsetu-number*))) +;; ###jhod Removed the char-boundary stuff, as I *THINK* we can only move by whole chars... +;; (if (eq egg:*sho-bunsetu-face* 'modeline) +;; (+ point (1+ (char-boundary-p point))) +;; point)) (if (eq egg:*sho-bunsetu-face* 'modeline) - (+ point (1+ (char-boundary-p point))) + (+ point 1) point)) + (+ (bunsetu-position (1- bunsetu-end)) (length (bunsetu-kanji (1- bunsetu-end))))))))) (defun egg:bunsetu-face-off () (and egg:*dai-bunsetu-face* - (overlayp egg:*dai-bunsetu-overlay*) - (delete-overlay egg:*dai-bunsetu-overlay*)) + (extentp egg:*dai-bunsetu-extent*) + (delete-extent egg:*dai-bunsetu-extent*)) (and egg:*sho-bunsetu-face* - (overlayp egg:*sho-bunsetu-overlay*) - (delete-overlay egg:*sho-bunsetu-overlay*)) + (extentp egg:*sho-bunsetu-extent*) + (delete-extent egg:*sho-bunsetu-extent*)) ) (defun henkan-goto-bunsetu (number) (setq *bunsetu-number* (check-number-range number 0 (1- (wnn-server-bunsetu-suu)))) (goto-char (bunsetu-position *bunsetu-number*)) -; (egg:move-bunsetu-overlay) +; (egg:move-bunsetu-extent) (egg:bunsetu-face-on) ) @@ -1259,7 +1269,7 @@ (goto-char (bunsetu-position min)) (henkan-insert-kouho min max) (goto-char point)) -; (egg:move-bunsetu-overlay) +; (egg:move-bunsetu-extent) (egg:bunsetu-face-on) (egg:henkan-face-on) ) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/egg/egg.el --- a/lisp/egg/egg.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/egg/egg.el Mon Aug 13 09:13:56 2007 +0200 @@ -61,8 +61,11 @@ ;;; (eval-when (load) (require 'wnn-client)) ;;; -(defvar egg-version "3.09" "Version number of this version of Egg. ") +; last master version +;;; (defvar egg-version "3.09" "Version number of this version of Egg. ") ;;; Last modified date: Fri Sep 25 12:59:00 1992 +(defvar egg-version "3.09 xemacs" "Version number of this version of Egg. ") +;;; Last modified date: Wed Feb 05 20:45:00 1997 ;;;; $B=$@5MW5a%j%9%H(B @@ -70,6 +73,11 @@ ;;;; $B=$@5%a%b(B +;;; 97.2.05 modified by J.Hein +;;; Lots of mods to make it XEmacs workable. Most fixes revolve around the fact that +;;; Mule/et al assumes that all events are keypress events unless specified otherwise. +;;; Also modified to work with the new charset names and API + ;;; 95.6.5 modified by S.Tomura ;;; $BJQ49D>8e$KO"B3$7$FJQ49$9$k>l9g$rG'<1$9$k$?$a$K!"(B"-in-cont" $B$K4XO"$7$?(B ;;; $BItJ,$rDI2C$7$?!#!J$3$NItJ,$O>-Mh:F=$@5$9$kM=Dj!#!K(B @@ -384,12 +392,24 @@ ;;;; Aug-25-88 toroku-region$B$GEPO?$9$kJ8;zNs$+$i(Bno graphic character$B$r(B ;;;; $B<+F0E*$K=|$/$3$H$K$7$?!#(B +(provide 'egg) + ;; XEmacs addition: (and remove disable-undo variable) ;; For Emacs V18/Nemacs compatibility (and (not (fboundp 'buffer-disable-undo)) (fboundp 'buffer-flush-undo) (defalias 'buffer-disable-undo 'buffer-flush-undo)) +;; 97.2.4 Created by J.Hein to simulate Mule-2.3 +(defun read-event () + "Cheap 'n cheesy event filter to facilitate translation from Mule-2.3" + (setq event (make-event)) + (while (progn + (next-event event) + (not (key-press-event-p event))) + (dispatch-event event)) + (event-key event)) + (eval-when-compile (require 'egg-jsymbol)) ;;;---------------------------------------------------------------------- @@ -430,16 +450,13 @@ ;;; ;;;; -(defun characterp (form) - (numberp form)) - (defun coerce-string (form) (cond((stringp form) form) ((characterp form) (char-to-string form)))) (defun coerce-internal-string (form) (cond((stringp form) - (if (= (chars-in-string form) 1) + (if (= (length form) 1) (string-to-char form) form)) ((characterp form) form))) @@ -471,7 +488,7 @@ (while (null (setq val (read-jis-code-from-string str))) (beep) (setq str (read-from-minibuffer prompt str))) - (insert (make-character lc-jp (car val) (cdr val))))) + (insert (make-char (find-charset 'japanese-jisx0208) (car val) (cdr val))))) (defun hexadigit-value (ch) (cond((and (<= ?0 ch) (<= ch ?9)) @@ -765,7 +782,7 @@ (+ p menu:*select-item-no*))) (defun menu:select-goto-item-position (pos) - (let ((m 0) (i 0) (p 0)) + (let ((m 0) (p 0)) (while (<= (+ p (length (nth m menu:*select-menus*))) pos) (setq p (+ p (length (nth m menu:*select-menus*)))) (setq m (1+ m))) @@ -817,17 +834,17 @@ (defun menu:item-string (item) (cond((stringp item) item) - ((numberp item) (char-to-string item)) + ((characterp item) (char-to-string item)) ((consp item) (if menu:*display-item-value* (format "%s [%s]" (cond ((stringp (car item)) (car item)) - ((numberp (car item)) (char-to-string (car item))) + ((characterp (car item)) (char-to-string (car item))) (t "")) (cdr item)) (cond ((stringp (car item)) (car item)) - ((numberp (car item)) + ((characterp (car item)) (char-to-string (car item))) (t "")))) (t ""))) @@ -905,7 +922,7 @@ (let ((ch (preceding-char))) (cond( (<= ch ?$B%s(B) (delete-char -1) - (insert (make-character lc-jp ?\244 (char-component ch 2)))))))) + (insert (make-char (find-charset 'japanese-jisx0208) 36 (char-octet ch 1)))))))) (defun hiragana-paragraph () "hiragana paragraph at or after point." @@ -931,12 +948,11 @@ (defun katakana-region (start end) (interactive "r") - (let ((point (point))) - (goto-char start) - (while (re-search-forward kanji-hiragana end end) - (let ((ch (char-component (preceding-char) 2))) - (delete-char -1) - (insert (make-character lc-jp ?\245 ch)))))) + (goto-char start) + (while (re-search-forward kanji-hiragana end end) + (let ((ch (char-octet (preceding-char) 1))) + (delete-char -1) + (insert (make-char (find-charset 'japanese-jisx0208) 37 ch))))) (defun katakana-paragraph () "katakana paragraph at or after point." @@ -967,8 +983,8 @@ (goto-char (point-min)) (while (re-search-forward "\\cS\\|\\cA" (point-max) (point-max)) (let* ((ch (preceding-char)) - (ch1 (char-component ch 1)) - (ch2 (char-component ch 2))) + (ch1 (char-octet ch 0)) + (ch2 (char-octet ch 1))) (cond ((= ?\241 ch1) (let ((val (cdr (assq ch2 *hankaku-alist*)))) (if val (progn @@ -1054,7 +1070,7 @@ (delete-char -1) (let ((zen (cdr (assq ch *zenkaku-alist*)))) (if zen (insert zen) - (insert (make-character lc-jp ?\243 (+ ?\200 ch))))))))))) + (insert (make-char (find-charset 'japanese-jisx0208) 38 ch)))))))))) (defun zenkaku-paragraph () "zenkaku paragraph at or after point." @@ -1339,7 +1355,7 @@ (and (consp action) (or (stringp (car action)) (and (consp (car action)) - (numberp (car (car action)))) + (characterp (car (car action)))) (null (car action))) (or (null (car (cdr action))) (stringp (car (cdr action))))))) @@ -1570,7 +1586,8 @@ ;;; (defvar its:*buff-s* (make-marker)) -(defvar its:*buff-e* (set-marker-type (make-marker) t)) +(defvar its:*buff-e* (make-marker)) +(set-marker-insertion-type its:*buff-e* t) ;;; STATE unread ;;; |<-s p->|<- e ->| @@ -1628,7 +1645,7 @@ (defun its:peek-char () (if (= (point) its:*buff-e*) (if its:*interactive* - (setq unread-command-events (list (read-event))) + (setq unread-command-events (list (character-to-event(read-event)))) nil) (following-char))) @@ -1648,26 +1665,27 @@ (if its:*char-from-buff* (save-excursion (its:insert-char ch)) - (if ch (setq unread-command-events (list ch))))) + (if ch (setq unread-command-events (list (character-to-event ch)))))) (defun its:insert-char (ch) (insert ch)) (defun its:ordinal-charp (ch) - (and (numberp ch) (<= ch 127) + (and (characterp ch) (<= ch 127) (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-self-insert-command))) (defun its:delete-charp (ch) - (and (numberp ch) (<= ch 127) + (and (characterp ch) (<= ch 127) (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-backward-delete-char))) (defun fence-self-insert-command () (interactive) + (setq ch (event-to-character last-command-event)) (cond((or (not egg:*input-mode*) - (null (get-next-map its:*current-map* last-command-event))) - (insert last-command-event)) + (null (get-next-map its:*current-map* ch))) + (insert ch)) (t - (insert last-command-event) + (insert ch) (its:translate-region (1- (point)) (point) t)))) ;;; @@ -1707,7 +1725,7 @@ (if quit-flag (progn (setq quit-flag nil) - (setq unread-command-events (list ?\^G)))))) + (setq unread-command-events (list (character-to-event ?\^G))))))) (defun car-string-lessp (item1 item2) (string-lessp (car item1) (car item2))) @@ -1804,7 +1822,7 @@ (cons (list string (let ((action-output (action-output action))) (cond((and (consp action-output) - (numberp (car action-output))) + (characterp (car action-output))) (format "%s..." (nth (car action-output) (cdr action-output)))) ((stringp action-output) @@ -1888,7 +1906,7 @@ (setq action (get-action newmap)) (cond - ((and its:*interactive* (not its:*char-from-buff*) (numberp ch) (= ch ?\^@)) + ((and its:*interactive* (not its:*char-from-buff*) (characterp ch) (= ch ?\^@)) (delete-region its:*buff-s* (point)) (let ((i 1)) (while (<= i its:*level*) @@ -2081,7 +2099,7 @@ (set-marker its:*buff-s* nil) (set-marker its:*buff-e* nil) - (if (and its:*interactive* ch) (setq unread-command-events (list ch))) + (if (and its:*interactive* ch) (setq unread-command-events (list (character-to-event ch)))) )) ;;;---------------------------------------------------------------------- @@ -2189,39 +2207,38 @@ ;;; ;;; -(defvar its:*reset-mode-line-format* nil) - -(if its:*reset-mode-line-format* - (setq-default mode-line-format - (cdr mode-line-format))) - -(if (not (egg:find-symbol-in-tree 'mode-line-egg-mode mode-line-format)) +(defvar its:*reset-modeline-format* nil) + +(if its:*reset-modeline-format* + (setq-default modeline-format + (cdr modeline-format))) + +(if (not (egg:find-symbol-in-tree 'mode-line-egg-mode modeline-format)) (setq-default - mode-line-format - (cons (list 'mc-flag - (list 'display-minibuffer-mode-in-minibuffer - ;;; minibuffer mode in minibuffer - (list - (list 'its:*previous-map* "<" "[") - 'mode-line-egg-mode - (list 'its:*previous-map* ">" "]") - ) + modeline-format + (cons (list 'display-minibuffer-mode-in-minibuffer + ;;; minibuffer mode in minibuffer + (list + (list 'its:*previous-map* "<" "[") + 'mode-line-egg-mode + (list 'its:*previous-map* ">" "]") + ) ;;;; minibuffer mode in mode line - (list - (list 'minibuffer-window-selected - (list 'display-minibuffer-mode - "m" - " ") + (list + (list 'minibuffer-window-selected + (list 'display-minibuffer-mode + "m" " ") - (list 'its:*previous-map* "<" "[") - (list 'minibuffer-window-selected - (list 'display-minibuffer-mode - 'mode-line-egg-mode-in-minibuffer - 'mode-line-egg-mode) + " ") + (list 'its:*previous-map* "<" "[") + (list 'minibuffer-window-selected + (list 'display-minibuffer-mode + 'mode-line-egg-mode-in-minibuffer 'mode-line-egg-mode) - (list 'its:*previous-map* ">" "]") - ))) - mode-line-format))) + 'mode-line-egg-mode) + (list 'its:*previous-map* ">" "]") + )) + modeline-format))) ;;; ;;; minibuffer $B$G$N%b!<%II=<($r$9$k$?$a$K(B nemacs 4 $B$GDj5A$5$l$?(B @@ -2276,8 +2293,7 @@ (progn (setq its:*current-map* (its:get-mode-map name)) (egg:mode-line-display)) - (beep)) - ) + (beep))) (defvar its:*select-mode-menu* '(menu "Mode:" nil)) @@ -2351,11 +2367,10 @@ (defun toggle-egg-mode () (interactive) - (if mc-flag - (if egg:*mode-on* (fence-toggle-egg-mode) - (progn - (setq egg:*mode-on* t) - (egg:mode-line-display))))) + (if egg:*mode-on* (fence-toggle-egg-mode) + (progn + (setq egg:*mode-on* t) + (egg:mode-line-display)))) (defun fence-toggle-egg-mode () (interactive) @@ -2418,7 +2433,7 @@ (defconst egg:*fence-close* "|" "*$B%U%'%s%9$N=*E@$r<($9J8;zNs(B") (defconst egg:*fence-face* nil "*$B%U%'%s%9I=<($KMQ$$$k(B face $B$^$?$O(B nil") (make-variable-buffer-local - (defvar egg:*fence-overlay* nil "$B%U%'%s%9I=<(MQ(B overlay")) + (defvar egg:*fence-extent* nil "$B%U%'%s%9I=<(MQ(B extent")) (defvar egg:*face-alist* '(("nil" . nil) @@ -2442,18 +2457,16 @@ (setq egg:*fence-open* (or open "") egg:*fence-close* (or close "") egg:*fence-face* face) - (if (overlayp egg:*fence-overlay*) - (overlay-put egg:*fence-overlay* 'face egg:*fence-face*)) + (if (extentp egg:*fence-extent*) + (set-extent-property egg:*fence-extent* 'face egg:*fence-face*)) t) (error "Wrong type of argument: %s %s %s" open close face))) -;(defconst egg:*region-start* (make-marker)) -;(defconst egg:*region-end* (set-marker-type (make-marker) t)) (defvar egg:*region-start* nil) -(defvar egg:*region-end* nil) (make-variable-buffer-local 'egg:*region-start*) +(set-default 'egg:*region-start* nil) +(defvar egg:*region-end* nil) (make-variable-buffer-local 'egg:*region-end*) -(set-default 'egg:*region-start* nil) (set-default 'egg:*region-end* nil) (defvar egg:*global-map-backup* nil) (defvar egg:*local-map-backup* nil) @@ -2470,10 +2483,9 @@ (defun egg-self-insert-command (arg) (interactive "p") (if (and (not buffer-read-only) - mc-flag egg:*mode-on* egg:*input-mode* (not egg:*in-fence-mode*) ;;; inhibit recursive fence mode - (not (= last-command-event ? ))) + (not (= (event-to-character last-command-event) ? ))) (egg:enter-fence-mode-and-self-insert) (progn ;; treat continuous 20 self insert as a single undo chunk. @@ -2492,7 +2504,7 @@ (if (<= 1 arg) (funcall self-insert-after-hook (- (point) arg) (point))) - (if (= last-command-event ? ) (egg:do-auto-fill)))))) + (if (= (event-to-character last-command-event) ? ) (egg:do-auto-fill)))))) ;; ;; $BA03NDjJQ49=hM}4X?t(B @@ -2525,8 +2537,8 @@ (setq egg:*fence-open-in-cont* (or open "") egg:*fence-close-in-cont* (or close "") egg:*fence-face-in-cont* face) - (if (overlayp egg:*fence-overlay*) - (overlay-put egg:*fence-overlay* 'face egg:*fence-face*)) + (if (extentp egg:*fence-extent*) + (set-extent-property egg:*fence-extent* 'face egg:*fence-face*)) t) (error "Wrong type of argument: %s %s %s" open close face))) @@ -2568,16 +2580,16 @@ (defun egg:fence-face-on () (if egg:*fence-face* (progn - (if (overlayp egg:*fence-overlay*) + (if (extentp egg:*fence-extent*) nil - (setq egg:*fence-overlay* (make-overlay 1 1 nil t)) - (if egg:*fence-face* (overlay-put egg:*fence-overlay* 'face egg:*fence-face*))) - (move-overlay egg:*fence-overlay* egg:*region-start* egg:*region-end* ) ))) + (setq egg:*fence-extent* (make-extent 1 1 nil t)) + (if egg:*fence-face* (set-extent-property egg:*fence-extent* 'face egg:*fence-face*))) + (set-extent-endpoints egg:*fence-extent* egg:*region-start* egg:*region-end* ) ))) (defun egg:fence-face-off () (and egg:*fence-face* - (overlayp egg:*fence-overlay*) - (delete-overlay egg:*fence-overlay*) )) + (extentp egg:*fence-extent*) + (detach-extent egg:*fence-extent*) )) (defun enter-fence-mode () ;; XEmacs change: @@ -2594,7 +2606,7 @@ (or (markerp egg:*region-start*) (setq egg:*region-start* (make-marker))) (set-marker egg:*region-start* (point)) (insert egg:*fence-close*) - (or (markerp egg:*region-end*) (setq egg:*region-end* (set-marker-type (make-marker) t))) + (or (markerp egg:*region-end*) (set-marker-insertion-type (setq egg:*region-end* (make-marker)) t)) (set-marker egg:*region-end* egg:*region-start*) (egg:fence-face-on) (goto-char egg:*region-start*) @@ -2740,7 +2752,7 @@ (defvar fence-mode-map (make-keymap)) -(substitute-key-definition 'self-insert-command +(substitute-key-definition 'egg-self-insert-command 'fence-self-insert-command fence-mode-map global-map) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/egg/eggrc-wnn --- a/lisp/egg/eggrc-wnn Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/egg/eggrc-wnn Mon Aug 13 09:13:56 2007 +0200 @@ -55,7 +55,24 @@ (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 15 t t) ; (add-wnn-dict "wnncons/tankan2.dic" "" 1 nil nil) ; (add-wnn-dict "wnncons/tankan3.dic" "" 1 nil nil) - (set-wnn-param 5 10 2 45 0 80 5 1 20 0 400 -100 400 80 200 2 200) + (wnn-server-set-param '(wnn_n 5 + wnn_nsho 10 + wnn_hindo 2 + wnn_len 45 + wnn_jiri 0 + wnn_flag 80 + wnn_jisho 5 + wnn_sbn 1 + wnn_dbn_len 20 + wnn_sbn_cnt 0 + wnn_suuji 400 + wnn_kana -100 + wnn_eisuu 400 + wnn_kigou 80 + wnn_toji_kakko 200 + wnn_fuzokogo 2 + wnn_kaikakko 200)) +; (set-wnn-param 5 10 2 45 0 80 5 1 20 0 400 -100 400 80 200 2 200) (add-wnn-notrans-dict "usr/$USER/katakana" 15 t) (add-wnn-bmodify-dict "usr/$USER/bunsetsu" 15 t) @@ -80,7 +97,24 @@ (set-wnn-reverse t) (set-wnn-fuzokugo "iwanami/kougo.fzk") (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 15 t t) - (set-wnn-param 2 10 2 45 1 80 5 1 50 -20 400 -10 100 -100 200 0 200) + (wnn-server-set-param '(wnn_n 2 + wnn_nsho 10 + wnn_hindo 2 + wnn_len 45 + wnn_jiri 1 + wnn_flag 80 + wnn_jisho 5 + wnn_sbn 1 + wnn_dbn_len 50 + wnn_sbn_cnt -20 + wnn_suuji 400 + wnn_kana -10 + wnn_eisuu 100 + wnn_kigou -100 + wnn_toji_kakko 200 + wnn_fuzokogo 2 + wnn_kaikakko 200)) +; (set-wnn-param 2 10 2 45 1 80 5 1 50 -20 400 -10 100 -100 200 0 200) ) @@ -101,7 +135,24 @@ (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) ; (add-wnn-dict "wnncons/tankan2.dic" "" 1 nil nil) ; (add-wnn-dict "wnncons/tankan3.dic" "" 1 nil nil) - (set-wnn-param 2 10 2 45 5 80 5 1 40 0 400 -100 400 80 200 2 200) + (wnn-server-set-param '(wnn_n 2 + wnn_nsho 10 + wnn_hindo 2 + wnn_len 45 + wnn_jiri 5 + wnn_flag 80 + wnn_jisho 5 + wnn_sbn 1 + wnn_dbn_len 40 + wnn_sbn_cnt 0 + wnn_suuji 400 + wnn_kana -100 + wnn_eisuu 400 + wnn_kigou 80 + wnn_toji_kakko 200 + wnn_fuzokogo 2 + wnn_kaikakko 200)) +; (set-wnn-param 2 10 2 45 5 80 5 1 40 0 400 -100 400 80 200 2 200) (set-wnn-reverse t) (set-wnn-fuzokugo "pubdic/full.fzk") (add-wnn-dict "pubdic/kihon.dic" (concat wnn-usr-dic-dir "/kihon.h") 5 nil t) @@ -117,7 +168,24 @@ (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) ; (add-wnn-dict "wnncons/tankan2.dic" "" 1 nil nil) ; (add-wnn-dict "wnncons/tankan3.dic" "" 1 nil nil) - (set-wnn-param 2 10 2 45 1 80 5 1 50 -20 400 -10 100 -100 200 0 200) + (wnn-server-set-param '(wnn_n 2 + wnn_nsho 10 + wnn_hindo 2 + wnn_len 45 + wnn_jiri 1 + wnn_flag 80 + wnn_jisho 5 + wnn_sbn 1 + wnn_dbn_len 50 + wnn_sbn_cnt -20 + wnn_suuji 400 + wnn_kana -10 + wnn_eisuu 100 + wnn_kigou -100 + wnn_toji_kakko 200 + wnn_fuzokogo 2 + wnn_kaikakko 200)) +; (set-wnn-param 2 10 2 45 1 80 5 1 50 -20 400 -10 100 -100 200 0 200) ) @@ -132,14 +200,48 @@ (add-wnn-dict "sys/level_2.dic" (concat wnn-usr-dic-dir "/level_2.h") 1 nil t) (add-wnn-dict "sys/basic.dic" (concat wnn-usr-dic-dir "/basic.h") 7 nil t) (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) (set-wnn-reverse t) (set-wnn-fuzokugo "sys/full.con") (add-wnn-dict "sys/level_1.dic" (concat wnn-usr-dic-dir "/level_1.h") 4 nil t) (add-wnn-dict "sys/level_2.dic" (concat wnn-usr-dic-dir "/level_2.h") 1 nil t) (add-wnn-dict "sys/basic.dic" (concat wnn-usr-dic-dir "/basic.h") 7 nil t) (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) ) ((eq wnn-server-type 'tserver) (set-wnn-reverse nil) @@ -147,13 +249,47 @@ (add-wnn-dict "sys/cns_ch.dic" (concat wnn-usr-dic-dir "/cns_ch.h") 4 nil t) (add-wnn-dict "sys/cns_wd.dic" (concat wnn-usr-dic-dir "/cns_wd.h") 1 nil t) (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) (set-wnn-reverse t) (set-wnn-fuzokugo "sys/full.con") (add-wnn-dict "sys/cns_ch.dic" (concat wnn-usr-dic-dir "/cns_ch.h") 4 nil t) (add-wnn-dict "sys/cns_wd.dic" (concat wnn-usr-dic-dir "/cns_wd.h") 1 nil t) (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) ) ((eq wnn-server-type 'kserver) (set-wnn-reverse nil) @@ -163,7 +299,24 @@ (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) ; (add-wnn-dict (concat wnn-usr-dic-dir "/hangul") "" 5 t t) ; (add-wnn-dict (concat wnn-usr-dic-dir "/fuzokugo") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) (set-wnn-reverse t) (set-wnn-fuzokugo "sys/full.fzk") ; (add-wnn-dict "sys/hword.dic" (concat wnn-usr-dic-dir "/hword.h") 4 nil t) @@ -171,7 +324,24 @@ (add-wnn-dict (concat wnn-usr-dic-dir "/ud") "" 5 t t) ; (add-wnn-dict (concat wnn-usr-dic-dir "/hangul") "" 5 t t) ; (add-wnn-dict (concat wnn-usr-dic-dir "/fuzokugo") "" 5 t t) - (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) + (wnn-server-set-param '(wnn_n 1 + wnn_nsho 5 + wnn_hindo 2 + wnn_len 750 + wnn_jiri 10 + wnn_flag 80 + wnn_jisho 10 + wnn_sbn 5 + wnn_dbn_len 1000 + wnn_sbn_cnt 50 + wnn_suuji 0 + wnn_kana -200 + wnn_eisuu 0 + wnn_kigou 0 + wnn_toji_kakko 0 + wnn_fuzokogo 16 + wnn_kaikakko 0)) +; (set-wnn-param 1 5 2 750 10 80 10 5 1000 50 0 -200 0 0 0 16 0) ) ) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/electric/ebuff-menu.el --- a/lisp/electric/ebuff-menu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/electric/ebuff-menu.el Mon Aug 13 09:13:56 2007 +0200 @@ -193,7 +193,7 @@ (setq i (1+ i)))) (define-key map "\C-z" 'suspend-emacs) (define-key map "v" 'Electric-buffer-menu-mode-view-buffer) - (define-key map (char-to-string help-char) 'Helper-help) + (define-key map (vector help-char) 'Helper-help) (define-key map "?" 'Helper-describe-bindings) (define-key map "\C-c" nil) (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit) @@ -280,7 +280,7 @@ (message "%s" (if (and (eq (key-binding "\C-c\C-c") 'Electric-buffer-menu-quit) (eq (key-binding " ") 'Electric-buffer-menu-select) - (eq (key-binding (char-to-string help-char)) 'Helper-help) + (eq (key-binding (vector help-char)) 'Helper-help) (eq (key-binding "?") 'Helper-describe-bindings)) (substitute-command-keys "Type C-c C-c to exit, Space to select, Type \\[Electric-buffer-menu-quit] to exit, \ diff -r 498bf5da1c90 -r 0d2f883870bc lisp/electric/echistory.el --- a/lisp/electric/echistory.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/electric/echistory.el Mon Aug 13 09:13:56 2007 +0200 @@ -67,7 +67,7 @@ (define-key electric-history-map "\C-c\C-c" 'Electric-history-quit) (define-key electric-history-map "\C-]" 'Electric-history-quit) (define-key electric-history-map "\C-z" 'suspend-emacs) - (define-key electric-history-map (char-to-string help-char) 'Helper-help) + (define-key electric-history-map (vector help-char) 'Helper-help) ;; XEmacs (define-key electric-history-map 'backspace 'previous-line) (define-key electric-history-map "?" 'Helper-describe-bindings) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/electric/ehelp.el --- a/lisp/electric/ehelp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/electric/ehelp.el Mon Aug 13 09:13:56 2007 +0200 @@ -65,7 +65,7 @@ (define-key map [(control ?7)] 'electric-help-undefined) (define-key map [(control ?8)] 'electric-help-undefined) (define-key map [(control ?9)] 'electric-help-undefined) - (define-key map (char-to-string help-char) 'electric-help-help) + (define-key map (vector help-char) 'electric-help-help) (define-key map "?" 'electric-help-help) ;; XEmacs addition (define-key map 'help 'electric-help-help) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/electric/helper.el --- a/lisp/electric/helper.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/electric/helper.el Mon Aug 13 09:13:56 2007 +0200 @@ -52,7 +52,7 @@ ;(define-key Helper-help-map "f" 'Helper-describe-function) ;(define-key Helper-help-map "v" 'Helper-describe-variable) (define-key Helper-help-map "?" 'Helper-help-options) - (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options) + (define-key Helper-help-map (vector help-char) 'Helper-help-options) (fset 'Helper-help-map Helper-help-map)) (defun Helper-help-scroller () diff -r 498bf5da1c90 -r 0d2f883870bc lisp/eos/sun-eos-common.el --- a/lisp/eos/sun-eos-common.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/eos/sun-eos-common.el Mon Aug 13 09:13:56 2007 +0200 @@ -358,7 +358,7 @@ (graphics (eos::annotation-get-glyph type device-type)) (face (eos::annotation-get-face type device-type)) ) - (setq anot (make-annotation graphics (point) 'whitespace)) + (setq anot (make-annotation graphics (point) 'outside-margin)) (set-annotation-data anot uid) (set-extent-face anot face) (eos::add-to-annotation-list anot type) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/games/mine.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/games/mine.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,1190 @@ +;;; mine.el --- Mine game for GNU Emacs + +;; Author: Jacques Duthen +;; Keywords: games +;; Time-stamp: <97/01/20 14:37:36 duthen> +;; Version: 1.17 + +(defconst mine-version-number "1.17" "Emacs Mine version number.") +(defconst mine-version (format "Emacs Mine v%s by Jacques Duthen © 1997" + mine-version-number) + "Full Emacs Mine version number.") + +;; This file is not yet 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: + +;; The object of this classical game is to locate the hidden mines. +;; To do this, you hit the squares on the game board that do not +;; contain mines, and you mark the squares that do contain mines. + +;; The number of hidden mines remaining in the mine field is indicated +;; inside the buffer. Every time you mark a square as a mine, this +;; number decreases by one, even if you incorrectly mark a square. + +;; To hit a square: Point to the square, and click the left button. +;; If the square is a mine, you loose. +;; If the square isn't a mine, a number appears, which represents +;; the number of mines in the surrounding eight squares. + +;; To mark a square as a mine: Point to the square, and click +;; the right button. + +;; To play Mine, compile it if you want, load it, and type `M-x mine'. + +;; To get help and doc, see the functions `mine' and `mine-help' +;; (ie. type `?' in the *Mine* buffer or type `C-h f mine') + +;; This module has been developed and tested with GNU Emacs 19.31.1, +;; but it should run with any GNU Emacs 19.* (at least with versions +;; superior to 19.31). + +;; This module has not been tested (yet) with XEmacs. It may or may +;; not run (can anybody tell me?). + +;; Send any comment or bug report (do you expect to find any? ;-) to me: +;; duthen@cegelec-red.fr (Jacques Duthen) + +;; Good luck. + +;; 1.17 Thanks to Vladimir Alexiev . +;; Fix bug: (void-function unless), add minimal support for xemacs. +;; (mine-xemacs-p): Added. +;; (event-point): New function. +;; (mine-mouse-hit, mine-mouse-mark): Use (interactive "@e") and `event-point' +;; (mine-init-mode-map): Support xemacs mouse binding. +;; (mine-make-face): Support xemacs get-face. +;; (mine-goto): Support `auto-show-make-point-visible' as well as +;; `hscroll-point-visible'. + +;; 1.16 Initial released version. + +;;; Code: + +(defvar mine-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + +;;; ================================================================ +;;; User Variables: + +;;; -1- size + +;;; The mine field is a rectangle (mine-xmax x mine-ymax), which is +;;; duplicated to fill a bigger rectangle periodically tiled with the +;;; smaller one, the period being (mine-xmax x mine-ymax). + +(defvar mine-xmax 16 "*The logical width of the mine field.") +(defvar mine-ymax 24 "*The logical height of the mine field.") + +(defvar mine-mines-% 16 + "*Percentage (between 0 and 100) of mines in the mine field.") + +(defvar mine-torus 't + "*Non-nil (the default) to play the game on a periodic board (a torus).") + +(defvar mine-nb-tiles-x 2 + "*Number of duplications in the x direction, when `mine-torus' is non-nil. +Indicate the number of times the original mine field is duplicated +in the x direction. +It's better looking when it's an integer. +nil means fill exactly the whole window. +0 means fill the whole window with the biggest integer that fits. +a negative number means use exactly the opposite number. If it's +too big, the rows are truncated by emacs. Automatic horizontal +scrolling will occur if you move to an invisible point. +a positive float means limit to the window width if needed. +a positive integer means limit to the window width if needed, +with the biggest possible integer value anyway. +") + +(defvar mine-nb-tiles-y 2 + "*Number of duplications in the y direction, when `mine-torus' is non-nil. +Indicate the number of times the original mine field is duplicated +in the y direction. +It's better looking when it's an integer. +nil means fill exactly the whole window. +0 means fill the whole window with the biggest integer that fits. +a negative number means use exactly the opposite number. If it's +too big, the rows will be simply scrolled up or down by emacs. +a positive float means limit to the window height if needed. +a positive integer means limit to the window height if needed, +with the biggest possible integer value anyway. +") + +;;; -2- square characters + +;;; All these characters may be changed but the first three ones +;;; `unmarked' `marked' `zero' must differ from each other. + +(defvar mine-char-unmarked ?- + "*Character for a square not yet marked nor hit.") +(defvar mine-char-marked ?@ + "*Character for a square marked as containing a mine.") +(defvar mine-char-zero ?\ + "*Character for a square hit with no adjacent mine.") + +(defvar mine-char-pad ?\ + "*Character to pad in the x direction or nil (not yet implemented).") +(defvar mine-char-not-found ?o + "*Character for a square marked but with no mine.") +(defvar mine-char-bogus ?x + "*Character for a square not marked but with a mine.") + +;;; -3- colors + +(defvar mine-colorp (if window-system 't 'nil) + "*Non-nil means with colors. Nil means in black and white.") + +(defvar mine-colors nil + "*Set this variable to override the colors defined by +`mine-default-colors' (use the same format).") + +(defconst mine-default-colors + '((mine-face-unmarked . "LightBlue") + (mine-face-marked . "Red") + (0 . nil) + (1 . "Cyan") + (2 . "Green") + (3 . "Yellow") + (4 . "Orange") + (5 . "OrangeRed") + (6 . "Red") + (7 . "Red") + (8 . "Red") + (mine-face-pad . nil) + (mine-face-not-found . "Red") + (mine-face-bogus . "Red") + ) + "A-list of default colors for Mine faces. Don't change its value. +You can override these settings with `mine-colors' using the same format.") + +;;; -4- redisplay + +(defvar mine-level 2 + "*Redisplay speed. 0 is the slowest redisplay, 5 is the fastest one. +0 means redisplay when every single square changes. +1 means redisplay when one square and its periodic images change. +2 means redisplay every `mine-count1-max' change. +3 means redisplay every `mine-count1-max'*`mine-count2-max' change. +-1 or nil means redisplay only when all the changes are done. +") + +(defvar mine-count1-max 16 + "*See `mine-level'. +Redisplay when the number of empty squares which have changed +is greater than `mine-count1-max'. +8 means redisplay each time 8 squares have been changed. +-1 means redisplay only when all the changes are done.") + +(defvar mine-count2-max 4 + "*See `mine-level'. +Redisplay when the number of empty squares which have changed +is greater than `mine-count1-max'. +8 means redisplay each time 8 squares have been changed. +-1 means redisplay only when all the changes are done.") + +(defvar mine-hscroll-step 4 + "*Local value for `hscroll-step'") + +(defvar mine-mode-hook nil + "*Hook called by `mine-mode-hook'.") + +;;; ================================================================ +;;; Internal variables: + +(defvar mine-user-variables + '("Size" + mine-xmax mine-ymax mine-mines-% + mine-torus mine-nb-tiles-x mine-nb-tiles-y + "Square characters" + mine-char-unmarked mine-char-marked mine-char-zero + mine-char-pad mine-char-not-found mine-char-bogus + "Colors" + mine-colorp mine-colors + "Redisplay" + mine-level mine-count1-max mine-count2-max + "Scrolling" + mine-hscroll-step + "Hook" + mine-mode-hook)) + +(defvar mine-user-commands + '("Help" + mine mine-help mine-help-bindings mine-help-variables + "Mouse control" + mine-mouse-hit mine-mouse-mark + "Move" + mine-left mine-right mine-up mine-down + mine-bol mine-eol mine-top mine-bottom + "Hit and mark" + mine-hit-curpoint mine-mark-curpoint + "Quit" + mine-quit)) + +;; pad x factor == (if mine-char-pad 2 1) +(defvar mine-padx*) + +(defvar mine-width) +(defvar mine-height) + +;; (x y) of current point +(defvar mine-x) ;; 1 <= mine-x <= mine-width +(defvar mine-y) ;; 1 <= mine-y <= mine-height + +;; limits of the playable part of the board +(defvar mine-point-min) +(defvar mine-point-max) + +(defvar mine-point-remaining-mines) +(defvar mine-point-mines-hit) + +(defvar mine-mode-map nil) + +(defvar mine-real-mines) + +(defvar mine-nb-remaining-mines) +(defvar mine-nb-remaining-marks) +(defvar mine-nb-mines-hit) + +(defvar mine-faces) + +;;; This variable is more special rather than global. +(defvar mine-adjacent-points) + +(defvar mine-count1) +(defvar mine-count2) + +;;; ================================================================ +;;; Macros (stolen from "cl.el" (soon in "subr.el" (thanks to rms))) + +(eval-when-compile +(or (fboundp 'when) +(defmacro when (cond &rest body) + "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." + (list 'if cond (cons 'progn body))))) + +;;; ================================================================ +;;; User commands + +;;;###autoload +(defun mine (num) + "Play Mine. Optional prefix argument is the number of mines. + +To play Mine, type `\\[mine]' or `\\[universal-argument] NUM \\[mine]'. + +An optional prefix argument specifies the number of mines to be hidden +in the field. If no prefix argument is given, a percentage +`mine-mines-%' of the field will contain mines. + +What is Mine?\\ + +Mine is a classical game of hide and seek played on a rectangular grid +containing `mine-xmax' by `mine-ymax' squares (the mine field). + +Your opponent (Emacs, in this case) has hidden several mines within +this field. The object of the game is to find every hidden mine. + +When you're sure a square does NOT contain a mine, you can hit it: +move the mouse over the square and press `\\[mine-mouse-hit]' or +move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. + +If the square is a mine, you loose. +If the square isn't a mine, a number appears which represents +the number of mines in the surrounding eight squares. + +When you think a square DOES contain a mine, you can mark it: +move the mouse over the square and press `\\[mine-mouse-mark]' or +move the cursor with the usual keys and press `\\[mine-mark-curpoint]'. + +The number of hidden mines remaining in the mine field is indicated +inside the buffer. Every time you mark a square as a mine, this +number decreases by one, even if you incorrectly mark a square. + +If `mine-torus' is non-nil (the default), the Mine game is played over +a periodic field (like a torus). Each mine is hidden periodically +over the mine board `mine-nb-tiles-x' times in the x direction and +`mine-nb-tiles-y' times in the y direction. + +If `mine-colorp' is non-nil (the default, if the system allows it), +the game is displayed with colors. The colors can be chosen with the +variable `mine-colors'. + +If the redisplay is not fast enough, increase `mine-level'. If you +want to see a smoother (slower) redisplay, decrease `mine-level', +`mine-count1-max' and `mine-count2-max'. + +You can get help on `mine-mode' and its key bindings by pressing `\\[mine-help]' +while in the *Mine* buffer. +" + (interactive "P") + (switch-to-buffer "*Mine*") + (mine-mode) + (setq buffer-read-only 't) + (buffer-disable-undo (current-buffer)) + (setq mine-nb-remaining-mines + (or num (round (/ (* mine-xmax mine-ymax mine-mines-%) 100))) + mine-nb-remaining-marks mine-nb-remaining-mines) + (if (> mine-nb-remaining-mines (* mine-xmax mine-ymax)) + (error "Too many mines: %d" mine-nb-remaining-mines)) + (mine-init-faces) + (setq mine-real-mines (mine-init-mines mine-nb-remaining-mines)) + (setq mine-nb-mines-hit 0) + (mine-init-board) + (mine-reset-counters) + (mine-update-remaining-mines) + (setq hscroll-step mine-hscroll-step) + ;; initial position + (setq mine-x 1) + (setq mine-y 1) + (mine-goto mine-x mine-y) +) + +;; Mine mode is suitable only for specially formatted data. +(put 'mine-mode 'mode-class 'special) + +(defun mine-mode () + "Major mode for playing Mine. To learn how to play Mine, see `mine'. + +If you have a mouse, you can do:\\ + +`\\[mine-mouse-hit]' -- hit point +`\\[mine-mouse-mark]' -- mark or unmark a mine at point + +If you don't have a mouse, you can move the cursor over the mine +field with the usual mnemonic keys and: + +`\\[mine-hit-curpoint]' -- hit point +`\\[mine-mark-curpoint]' -- mark or unmark a mine at point + +`\\[mine-quit]' -- give up and see the hidden mines + +You can get help with: + +`\\[mine-help-variables]' -- get help on Mine variables +`\\[mine-help-bindings]' -- get help on Mine bindings + +\\{mine-mode-map} +" + (interactive) + (kill-all-local-variables) + (make-local-variable 'hscroll-step) + (use-local-map mine-mode-map) + (setq truncate-lines 't) + (setq major-mode 'mine-mode) + (setq mode-name "Mine") + (run-hooks 'mine-mode-hook) +) + +;;;###autoload +(defun mine-version () + "Return string describing the current version of Mine. +When called interactively, displays the version." + (interactive) + (if (interactive-p) + (message (mine-version)) + mine-version)) + +;;;###autoload +(defun mine-help () + "*Get help on `mine-mode'." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (describe-mode))) + +(defun mine-help-variables () + "*Get help on Mine variables." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (apropos-symbols mine-user-variables 't))) + +(defun mine-help-bindings () + "*Get help on Mine bindings." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (apropos-symbols mine-user-commands 't))) + +(defun mine-print-settings () + "*Print the current Mine settings (value of all the user variables)." + (interactive) + (with-output-to-temp-buffer "*scratch*" + (mine-print-variables mine-user-variables))) + +;;; ================================================================ +;;; Click events - nop hit mark + +;;; [jack] The elisp manual says: +;;; If you want to take action as soon as a button is pressed, +;;; you need to handle "button-down" events. +;;; The global map (cf. `mouse.el') has, by default, the binding: +;;; (define-key global-map [down-mouse-1] 'mouse-drag-region) +;;; It seems that this function "eats" the final event [mouse-1]. +;;; So, we need a local binding for [down-mouse-1] which shadows +;;; the global one and prevents `mouse-drag-region' from being called. +;;; Hence, in `mine-init-mode-map' I use the following binding: +;;; (define-key mine-mode-map [down-mouse-1] 'mine-mouse-nop) +;;; I found a better binding in "apropos.el" +;;; (define-key mine-mode-map [down-mouse-1] nil) +;;; but, as it does not work, let's go back to nop... + +(or (fboundp 'event-point) + (defun event-point (event) + (posn-point (event-end event)))) + +(defun mine-mouse-nop (event) + "Nop" + (interactive "e")) + +(defun mine-mouse-hit (event) + "Move point to the position clicked on with the mouse and hit this point." + (interactive "@e") + (if (mine-goto-point (event-point event)) + (mine-hit-curpoint) + (mine-message 'mine-msg-click-precisely))) + +(defun mine-mouse-mark (event) + "Move point to the position clicked on with the mouse and mark or unmark +this point." + (interactive "@e") + (if (mine-goto-point (event-point event)) + (mine-mark-curpoint) + (mine-message 'mine-msg-click-precisely))) + +;;; ================================================================ +;;; Key events - hit mark quit + +(defun mine-hit-curpoint () + "Hit point" + (interactive) + (mine-reset-counters) + (let ((c (following-char))) + (save-excursion + (cond + ((eq c mine-char-marked) + (mine-message 'mine-msg-unmark-before-hit)) + ((not (eq c mine-char-unmarked)) + (mine-message 'mine-msg-point-already-hit)) + ((mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-mines-hit (1+ mine-nb-mines-hit)) + (mine-update-mines-hit) + (mine-message 'mine-msg-loose) + (mine-quit)) + (t ;; the real job... + (let* ((x.y (mine-top-left (mine-point-to-x.y (point)))) + (pxy (cons (point) x.y)) + (mine-adjacent-points (list pxy))) ; special variable + (while mine-adjacent-points + (setq pxy (car mine-adjacent-points) + mine-adjacent-points (cdr mine-adjacent-points)) + (mine-deep-hit pxy)))))))) + +(defun mine-mark-curpoint () + "Mark or unmark current position" + (interactive) + (mine-reset-counters) + (let ((c (following-char))) + (save-excursion + (cond + ((eq c mine-char-unmarked) + (mine-mark-board (point)) + (setq mine-nb-remaining-marks + (1- mine-nb-remaining-marks)) + (if (mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-remaining-mines + (1- mine-nb-remaining-mines)))) + ((eq c mine-char-marked) + (mine-unmark-board (point)) + (setq mine-nb-remaining-marks + (1+ mine-nb-remaining-marks)) + (if (mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-remaining-mines + (1+ mine-nb-remaining-mines)))) + (t + (mine-message 'mine-msg-cannot-mark))) + (mine-update-remaining-mines)))) + +(defun mine-quit () + "*Display hidden and bogus mines." + (interactive) + (when (y-or-n-p "Do you want to see the remaining and bogus mines? ") + (mine-show-bogus-mines))) + +(defun mine-show-bogus-mines () + (mine-reset-counters) + (let ((nrb 0) (nbb 0) + (x.y (cons nil nil)) + (y 1) x + point c) + (while (<= y mine-ymax) + (setq x 1) + (setcdr x.y y) + (while (<= x mine-xmax) + (setq point (mine-xy-to-point x y) + c (char-after point)) + (cond + ((eq c mine-char-unmarked) + (setcar x.y x) + (when (mine-mine-at-xy-p x.y) + (setq nrb (1+ nrb)) + (mine-update-board point mine-char-not-found 'mine-face-not-found))) + ((eq c mine-char-marked) + (setcar x.y x) + (when (not (mine-mine-at-xy-p x.y)) + (setq nbb (1+ nbb)) + (mine-update-board point mine-char-bogus 'mine-face-bogus)))) + (setq x (1+ x))) + (setq y (1+ y))) + (mine-update-bogus-mines nrb nbb))) + +;;; ================================================================ +;;; Key events - moves + +(defun mine-left () + "Move left" + (interactive) + (setq mine-x (1- mine-x)) + (when (<= mine-x 0) + (while (<= mine-x mine-width) + (setq mine-x (+ mine-x mine-xmax))) + (setq mine-x (- mine-x mine-xmax))) + (mine-goto mine-x mine-y)) + +(defun mine-right () + "Move right" + (interactive) + (setq mine-x (1+ mine-x)) + (when (> mine-x mine-width) + (while (>= mine-x 0) + (setq mine-x (- mine-x mine-xmax))) + (setq mine-x (+ mine-x mine-xmax))) + (mine-goto mine-x mine-y)) + +(defun mine-up () + "Move up" + (interactive) + (setq mine-y (1- mine-y)) + (when (<= mine-y 0) + (while (<= mine-y mine-height) + (setq mine-y (+ mine-y mine-ymax))) + (setq mine-y (- mine-y mine-ymax))) + (mine-goto mine-x mine-y)) + +(defun mine-down () + "Move down" + (interactive) + (setq mine-y (1+ mine-y)) + (when (> mine-y mine-height) + (while (>= mine-y 0) + (setq mine-y (- mine-y mine-ymax))) + (setq mine-y (+ mine-y mine-ymax))) + (mine-goto mine-x mine-y)) + + +(defun mine-bol () + "Move to the beginning of the row" + (interactive) + (setq mine-x 1) + (mine-goto mine-x mine-y)) + +(defun mine-eol () + "Move to the end of the row" + (interactive) + (setq mine-x mine-width) + (mine-goto mine-x mine-y)) + +(defun mine-top () + "Move to the top of the column" + (interactive) + (setq mine-y 1) + (mine-goto mine-x mine-y)) + +(defun mine-bottom () + "Move to the bottom of the column" + (interactive) + (setq mine-y mine-height) + (mine-goto mine-x mine-y)) + +;;; ================================================================ +;;; Internal model functions + +(defun mine-init-mines (num-mines) + (random t) + (let ((mines (list)) (n num-mines) x y x.y) + (while (> n 0) + (setq n (1- n) + x (1+ (random mine-xmax)) + y (1+ (random mine-ymax)) + x.y (cons x y)) + (while (mine-member x.y mines 'nil) + ;; replace by the point to the right (or next row if eol) + (if (< x mine-xmax) + (setcar x.y (setq x (1+ x))) + (setcar x.y (setq x 1)) + (setcdr x.y (setq y (if (< y mine-ymax) (1+ y) 1))))) + (setq mines (cons x.y mines))) + mines)) + +(defun mine-mine-at-point-p (point slowp) + (mine-member (mine-top-left (mine-point-to-x.y point)) + mine-real-mines slowp)) + +(defun mine-mine-at-xy-p (x.y) + (mine-member x.y mine-real-mines 'nil)) + +;;; Returns non-nil if ELT is an element of LIST. +;;; Constant time execution if slowp is non-nil. +(defun mine-member (x.y list slowp) + (let ((found 'nil)) + (while (and list (or slowp (not found))) + (if (equal x.y (car list)) + (setq found 't)) + (setq list (cdr list))) + found)) + +;;; ================================================================ +;;; Internal model & interface functions + +(defun mine-pxy (x y) + (cons (mine-xy-to-point x y) (cons x y))) + +;; pxy == (point . (x . y)) +;; with 1 <= {xy} <= mine-{xy}max +(defun mine-deep-hit (pxy) + (interactive) + (let (point x.y c) + (setq point (car pxy) + x.y (cdr pxy) + c (char-after point)) + (cond + ((eq c mine-char-marked)) ;; free but marked (user bug) + ((not (eq c mine-char-unmarked))) ;; already done + ((mine-mine-at-xy-p x.y) + (error "Internal error: mine-deep-hit mine at %s" point)) + (t ;; the real job... + (let* ((adjacent-points (mine-adjacent-points point x.y)) + (nb-adjacent-mines (mine-nb-adjacent-mines adjacent-points))) + (mine-display-nb-adjacent-mines point nb-adjacent-mines) + (when (zerop nb-adjacent-mines) + ;; Stack overflow: "Lisp nesting exceeds max-lisp-eval-depth" + ;;(mapc 'mine-deep-hit adjacent-points) + (setq mine-adjacent-points + (nconc adjacent-points mine-adjacent-points)))))))) + +;; return == ((point . (x . y))*) +;; with 1 <= {xy} <= mine-{xy}max +(defun mine-adjacent-points (point x.y) + (mine-random-permut + (if mine-torus + (mine-adjacent-points-on-torus point x.y) + (mine-adjacent-points-no-torus point x.y)))) + +(defun mine-random-permut (l) + (let ((ll (nthcdr (random (length l)) l))) + (nconc ll l) + (prog1 (cdr ll) (setcdr ll ())))) + +(defun mine-adjacent-points-no-torus (point x.y) + (let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy) + ;; left column + (when (not (= x 1)) + (setq xx (1- x)) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (setq points (cons (mine-pxy xx y) points)) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points)))) + ;; middle column + (setq xx x) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points))) + ;; right column + (when (not (= x mine-xmax)) + (setq xx (1+ x)) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (setq points (cons (mine-pxy xx y) points)) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points)))) + (nreverse points))) + +(defun mine-adjacent-points-on-torus (point x.y) + (let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy) + ;; left column + (setq xx (if (= x 1) mine-xmax (1- x))) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq points (cons (mine-pxy xx y) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + ;; middle column + (setq xx x) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + ;; right column + (setq xx (if (= x mine-xmax) 1 (1+ x))) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq points (cons (mine-pxy xx y) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + (nreverse points))) + +;; l == ((p . (x . y))*) +(defun mine-nb-adjacent-mines (l) + (let ((nb 0) pxy x.y) + (while l + (setq pxy (car l) l (cdr l) x.y (cdr pxy)) + (if (mine-mine-at-xy-p x.y) + (setq nb (1+ nb)))) + nb)) + +;;; ================================================================ +;;; Mode map + +(defun mine-init-mode-map () + (let ((map (make-keymap)) (gm global-map)) + ;; All normally self-inserting keys (except digits) are undefined + (suppress-keymap map 'nil) + ;; Help + (define-key map "?" 'mine-help) + (define-key map "h" 'mine-help) + (define-key map "b" 'mine-help-bindings) + (define-key map "v" 'mine-help-variables) + (cond + (mine-xemacs-p + ;; Mouse control + (define-key map [mouse-1] 'mine-mouse-hit) + (define-key map [mouse-3] 'mine-mouse-mark) + ;; Mouse control to prevent problems + (define-key map [mouse-2] 'mine-mouse-nop)) + (t + ;; Mouse control + (define-key map [mouse-1] 'mine-mouse-hit) + (define-key map [mouse-3] 'mine-mouse-mark) + ;; Mouse control to prevent problems + (define-key map [mouse-2] 'mine-mouse-nop) + (define-key map [down-mouse-1] 'mine-mouse-nop) + (define-key map [down-mouse-2] 'mine-mouse-nop) + (define-key map [down-mouse-3] 'mine-mouse-nop) + (define-key map [drag-mouse-1] 'mine-mouse-nop) + (define-key map [drag-mouse-2] 'mine-mouse-nop) + (define-key map [drag-mouse-3] 'mine-mouse-nop) + (define-key map [mouse-2] 'mine-mouse-nop))) + ;; Move + (substitute-key-definition 'backward-char 'mine-left map gm) + (substitute-key-definition 'forward-char 'mine-right map gm) + (substitute-key-definition 'previous-line 'mine-up map gm) + (substitute-key-definition 'next-line 'mine-down map gm) + + (substitute-key-definition 'beginning-of-line 'mine-bol map gm) + (substitute-key-definition 'backward-word 'mine-bol map gm) + (substitute-key-definition 'backward-sexp 'mine-bol map gm) + (substitute-key-definition 'end-of-line 'mine-eol map gm) + (substitute-key-definition 'forward-word 'mine-eol map gm) + (substitute-key-definition 'forward-sexp 'mine-eol map gm) + (define-key map "\M-p" 'mine-top) + (define-key map "\M-n" 'mine-bottom) + ;; Hit and mark + (define-key map " " 'mine-hit-curpoint) + (define-key map "\C-m" 'mine-mark-curpoint) + (define-key map [kp-enter] 'mine-mark-curpoint) + (define-key map "m" 'mine-mark-curpoint) + (define-key map "q" 'mine-quit) + + (setq mine-mode-map map))) + +;;; ================================================================ +;;; Faces + +(defun mine-init-faces () + (setq mine-faces (list)) + (when mine-colorp + (let ((l (append mine-colors mine-default-colors)) + key.col key col name) + (while l + (setq key.col (car l) + l (cdr l) + key (car key.col) + col (cdr key.col)) + (when (null (assoc key mine-faces)) + (setq name + (cond + ((null key) nil) + ((symbolp key) (mine-make-face key col)) + ((not (integerp key)) + (error "Key should be a symbol or a number: '%s'" key)) + ((or (< key 0) (> key 8)) + (error "Key should be a number between 0 and 8: '%s'" key)) + (t + (setq name (intern (concat "mine-face-" key))) + (mine-make-face name col)))) + (setq mine-faces (cons (cons key name) mine-faces)))) + (setq mine-faces (nreverse mine-faces))))) + +(defun mine-make-face (name col) + (or (if (fboundp 'internal-find-face) + (internal-find-face name) + (find-face name)) + (let ((face (make-face name))) + (unless (or (not mine-xemacs-p) col) + (setq col (cdr (face-background 'default 'global)))) + (set-face-background face col) + face)) + name) + +(defun mine-get-face (key) + (cdr (assoc key mine-faces))) + +;;; ================================================================ +;;; Init board + +(defun mine-init-board () + (setq mine-padx* (if mine-char-pad 2 1)) + (if (not mine-torus) + (setq mine-width mine-xmax + mine-height mine-ymax) + (let (window-xmax window-nb-tiles-x window-xmax-int + window-ymax window-nb-tiles-y window-ymax-int) + (setq window-xmax (/ (window-width) mine-padx*) + window-nb-tiles-x (/ window-xmax mine-xmax) + window-xmax-int (* window-nb-tiles-x window-xmax)) + (setq mine-width + (max mine-xmax ; at least mine-xmax + (cond + ((null mine-nb-tiles-x) window-xmax) + ((not (numberp mine-nb-tiles-x)) + (error "mine-nb-tiles-x should be nil or a number: %s" + mine-nb-tiles-x)) + ((zerop mine-nb-tiles-x) window-xmax-int) + ((< mine-nb-tiles-x 0) + (floor (* mine-xmax (- mine-nb-tiles-x)))) + ((floatp mine-nb-tiles-x) + (min window-xmax (floor (* mine-xmax mine-nb-tiles-x)))) + (t (min window-xmax-int (* mine-xmax mine-nb-tiles-x)))))) + (setq window-ymax (- (window-height) 5) + window-nb-tiles-y (/ window-ymax mine-ymax) + window-ymax-int (* window-nb-tiles-y window-ymax)) + (setq mine-height + (max mine-ymax + (cond + ((null mine-nb-tiles-y) window-ymax) + ((not (numberp mine-nb-tiles-y)) + (error "mine-nb-tiles-y should be nil or a number: %s" + mine-nb-tiles-y)) + ((zerop mine-nb-tiles-y) window-ymax-int) + ((< mine-nb-tiles-y 0) + (floor (* mine-ymax (- mine-nb-tiles-y)))) + ((floatp mine-nb-tiles-y) + (min window-ymax (floor (* mine-ymax mine-nb-tiles-y)))) + (t (min window-ymax-int (* mine-ymax mine-nb-tiles-y)))))))) + (let ((buffer-read-only 'nil) + (face-unmarked (mine-get-face 'mine-face-unmarked)) + (face-pad (mine-get-face 'mine-face-pad)) + row col) + (erase-buffer) + (mine-insert-copyright) + (mine-insert-remaining-mines) + (mine-insert-mines-hit) + (setq mine-point-min (point)) + (setq row mine-height) + (while (>= (setq row (1- row)) 0) + (setq col (1- mine-width)) + (insert mine-char-unmarked) + (when face-unmarked + (put-text-property (1- (point)) (point) 'face face-unmarked)) + (while (>= (setq col (1- col)) 0) + (when mine-char-pad + (insert mine-char-pad) + (when face-pad + (put-text-property (1- (point)) (point) 'face face-pad))) + (insert mine-char-unmarked) + (when face-unmarked + (put-text-property (1- (point)) (point) 'face face-unmarked))) + (insert ?\n)) + (setq mine-point-max (1- (point))) + (mine-update-remaining-mines) + (mine-update-mines-hit) + (set-buffer-modified-p 'nil))) + +;;; ================================================================ +;;; Internal moves + +(defun mine-goto-point (point) + (let ((x.y (mine-point-to-x.y point))) + (setq mine-x (car x.y) mine-y (cdr x.y)) + (mine-goto mine-x mine-y) + (= point (point)))) + +(defun mine-goto (x y) + (goto-char (mine-xy-to-point x y)) + (cond ((fboundp 'hscroll-point-visible) + (hscroll-point-visible)) + ((fboundp 'auto-show-make-point-visible) + (auto-show-make-point-visible)))) + +;;; ================================================================ +;;; Conversions + +(defun mine-xy-to-point (x y) + ;; p = pmin + 2*w*(y-1) + 2*(x-1) + (+ mine-point-min + (* mine-padx* mine-width (1- y)) + (* mine-padx* (1- x)))) + +;;; Returns the topleft equivalent of point, +;;; on the periodic board, ie. converts point to model coordinates. +(defun mine-top-left (x.y) + (setcar x.y (1+ (mod (1- (car x.y)) mine-xmax))) + (setcdr x.y (1+ (mod (1- (cdr x.y)) mine-ymax))) + x.y) + +(defun mine-point-to-x.y (point) + (let (x y (p0 (- point mine-point-min))) + (cond + ((<= p0 0) + (setq x 1 y 1)) + ((>= point mine-point-max) + (setq x mine-width y mine-height)) + (t + ;; p = pmin + 2*w*(y-1) + 2*(x-1) + ;; y = (p - pmin)/2w + 1 + ;; x = (p - pmin - 2*w*(y-1)) / 2 + 1 + (setq y (1+ (/ p0 mine-width mine-padx*)) + x (1+ (/ (- p0 (* mine-padx* mine-width (1- y))) mine-padx*))))) + (cons x y))) + +;;; ================================================================ +;;; Screen display + +(defun mine-mark-board (point) + (mine-update-board point mine-char-marked 'mine-face-marked)) + +(defun mine-unmark-board (point) + (mine-update-board point mine-char-unmarked 'mine-face-unmarked)) + +(defun mine-display-nb-adjacent-mines (point nb) + (mine-update-board point + (if (zerop nb) mine-char-zero (+ ?0 nb)) + nb)) + +;; todo: enumerer tous les points periodiques +(defun mine-update-board (point c key) + (let ((buffer-read-only 'nil) + (face (mine-get-face key)) + (x.y (mine-top-left (mine-point-to-x.y point))) + x y) + (setq x (car x.y)) + (while (<= x mine-width) + (setq y (cdr x.y)) + (while (<= y mine-height) + (mine-update-point (mine-xy-to-point x y) c face) + (setq y (+ y mine-ymax))) + (setq x (+ x mine-xmax))) + (mine-reach-level 1) ; redisplay point and its periodic images + (set-buffer-modified-p 'nil))) + +(defun mine-update-point (point c face) + (goto-char point) + (delete-char 1) + (insert c) + (when face + (put-text-property point (point) 'face face)) + (mine-reach-level 0)) ; redisplay point + +(defun mine-reach-level (level) + (cond + ((null mine-level)) ; no update at all + ((< mine-level 0)) ; no update at all + ((zerop mine-level) ; unconditional update + (sit-for 0)) + ((zerop level)) ; wait for level 1 + ((= level 1) + (cond + ((= mine-level level) + (sit-for 0)) + ((= mine-count1 mine-count1-max) + (setq mine-count1 0) + (mine-reach-level (1+ level))) + (t (setq mine-count1 (1+ mine-count1))))) + ((= level 2) + (setq mine-count1 0) + (cond + ((= mine-level level) + (sit-for 0)) + ((= mine-count2 mine-count2-max) + (setq mine-count2 0) + (mine-reach-level (1+ level))) + (t (setq mine-count2 (1+ mine-count2))))) + ((= level 3) + (setq mine-count1 0) + (setq mine-count2 0) + (cond + ((= mine-level level) + (sit-for 0)))))) + +(defun mine-reset-counters () + (setq mine-count1 0 + mine-count2 0)) + +;;; ================================================================ +;;; Messages - init board + +(defun mine-insert-copyright () + (insert mine-version "\n\n")) + +(defun mine-insert-remaining-mines () + (insert (format "%16s" "Remaining mines") ":") + (setq mine-point-remaining-mines (point)) + (insert " \n")) + +(defun mine-insert-mines-hit () + (insert (format "%16s" "mines hit") ":") + (setq mine-point-mines-hit (point)) + (insert " \n\n")) + +;;; ================================================================ +;;; Messages - update board + +(defun mine-update-remaining-mines () + (let ((buffer-read-only 'nil)) + (save-excursion + (goto-char mine-point-remaining-mines) + (delete-char 3) + (insert (format "%3d" mine-nb-remaining-marks))) + (set-buffer-modified-p 'nil)) + (sit-for 0) + (message "mines remaining to find...%d" mine-nb-remaining-marks) + (when (and (zerop mine-nb-remaining-mines) + (zerop mine-nb-remaining-marks)) + (mine-message 'mine-msg-win))) + +(defun mine-update-mines-hit () + (let ((buffer-read-only 'nil)) + (save-excursion + (goto-char mine-point-mines-hit) + (delete-char 3) + (insert (format "%3d" mine-nb-mines-hit))) + (set-buffer-modified-p 'nil))) + +(defun mine-update-bogus-mines (nrb nbb) + (let ((buffer-read-only 'nil) + (msg (format "There were %d remaining mines and %d bogus mines" + nrb nbb))) + (save-excursion + (goto-char (point-max)) + (insert "\n" msg)) + (set-buffer-modified-p 'nil) + (message msg))) + +;;; ================================================================ +;;; Messages - write minibuffer + +(defun mine-message (msg) + (ding) + (cond + ((eq msg 'mine-msg-click-precisely) + (message "Please, click more precisely")) + ((eq msg 'mine-msg-unmark-before-hit) + (message "You must unmark point before hitting it.")) + ((eq msg 'mine-msg-point-already-hit) + (message "Point has already been hit.")) + ((eq msg 'mine-msg-cannot-mark) + (message "Can't (un)mark point...")) + ((eq msg 'mine-msg-loose) + (message "Sorry... There's a mine here...") + (sit-for 1) + (message "Sorry... There's a mine here... You lost!")) + ((eq msg 'mine-msg-win) + (message "Congratulations...") + (sit-for 1) + (message "Congratulations... You won!")) + (t + (message (format "%s" msg))))) + +(mine-init-mode-map) + +;;; ================================================================ + +(defun mine-print-variables (l) + (let (var) + (princ "(setq ") + (while l + (setq var (car l) l (cdr l)) + (cond + ((stringp var) (princ (format ";; %s\n " var))) + ((not (symbolp var)) (error "Not a symbol: %s" var)) + ((not (boundp var)) (error "Unboundp symbol: %s" var)) + (t (princ (format "%-20s'%s" var (symbol-value var))) + (when l (princ "\n "))))) + (princ "))\n"))) + +;;; ================================================================ + +;;(autoload 'apropos-print "apropos") +;;(autoload 'apropos-do-all "apropos") + +(if (not (boundp 'apropos-accumulator)) + (load "apropos")) + +(if (boundp 'apropos-item) +;; (Daniel.Pfeiffer's) old official version of apropos +(defun apropos-symbols (l &optional do-all) + (let ((ll (list))) + (while l + (when (not (stringp (car l))) + (setq ll (cons (car l) ll))) + (setq l (cdr l))) + (setq apropos-accumulator (nreverse ll))) + (or do-all (setq do-all apropos-do-all)) + (apropos-print + t + (lambda (p) + (let (doc symbol) + (while p + (setcar p + (list ; (s f v p) + (setq symbol (car p)) + (if (commandp symbol) + (if (setq doc (documentation symbol t)) + (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (and do-all + (user-variable-p symbol) + (if (setq doc (documentation-property + symbol 'variable-documentation t)) + (substring doc 0 (string-match "\n" doc)))))) + (setq p (cdr p))))) + t))) + +(provide 'mine) + +;;; mine.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,25 +1,4467 @@ -Fri Jan 3 16:20:42 1997 Steven L Baur - - * gnus-setup.el: Updated to gracefully handle installed auxilliary - packages like tm, and handle eventual integration of Red Gnus/Gnus - 5.4. - -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. +Mon Feb 10 14:19:55 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.12 is released. + +Mon Feb 10 12:47:41 1997 Lars Magne Ingebrigtsen + + * message.el (message-fetch-field): Accept an optional param. + (message-reply): Only fetch the first Message-ID. + + * gnus-score.el (gnus-summary-score-effect): Update mode line. + +Mon Feb 10 12:32:38 1997 Hrvoje Niksic + + * gnus-art.el: Simplify. + +Mon Feb 10 12:23:48 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-prev-page): Don't scroll when the + article buffer isn't visible. + + * gnus.el ((featurep 'gnus-xmas)): Removed + `gnus-make-local-hook'. + +Mon Feb 10 12:08:31 1997 Adrian Aichner + + * gnus-util.el (gnus-turn-off-edit-menu): Doc fix. + +Mon Feb 10 07:42:37 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-prepare-unthreaded): Make sure point + is at bol. + + * gnus-srvr.el (gnus-browse-mode-map): Define gnus-bug. + (gnus-server-mode-map): Ditto. + + * gnus-sum.el (gnus-summary-edit-article-done): Update original + article buffer. + + * gnus-uu.el (gnus-uu-digest-mail-forward): Restore window + config. + + * nnmail.el (nnmail-move-inbox): Make sure tofile exists before + setting modes. + + * gnus-xmas.el (gnus-xmas-region-active-p): New function. + + * gnus-ems.el (gnus-region-active-p): New function. + +Mon Feb 10 07:40:45 1997 Hrvoje Niksic + + * gnus-sum.el (gnus-summary-work-articles): Use zmacs-region. + +Mon Feb 10 07:06:44 1997 Lars Magne Ingebrigtsen + + * message.el (message-mode): Nix out all local variables. + + * gnus-art.el (gnus-summary-save-in-mail): Don't ask. + + * gnus-sum.el (gnus-ps-print-hook): New hook. + (gnus-summary-print-article): Use it. + + * message.el (message-reply): Make sure there is something + inserted as a To. + +Mon Feb 10 05:54:28 1997 Paul Franklin + + * gnus-group.el (gnus-group-edit-group): Ignore errors while + closing group. + +Mon Feb 10 05:22:09 1997 Steven L. Baur + + * messagexmas.el (message-xmas-maybe-fontify): New function. + (message-mode-hook): Use it. + +Sat Feb 8 21:18:25 1997 Lars Magne Ingebrigtsen + + * message.el (message-user-organization): Only use string values + of `gnus-local-organization'. + +Tue Feb 4 20:26:20 1997 Paul Franklin + + * nnmail.el (nnmail-get-spool-files): Don't call file-directory-p + on pop spool specifiers. + +Wed Feb 5 01:56:07 1997 Lars Magne Ingebrigtsen + + * message.el (message-delete-mh-headers): Changed default. + (message-send-mail-with-mh): Use it. + (message-mh-deletable-headers): Renamed. + + * gnus-sum.el (gnus-read-header): Don't do anything if the article + can't be requested. + +Wed Feb 5 01:51:07 1997 Joev Dubach + + * gnus-sum.el (gnus-select-newsgroup): Update group line. + +Tue Feb 4 20:23:30 1997 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-output-to-mail): Insert a newline before the + "From ". + + * nnml.el (nnml-request-move-article): Update active ranges. + (nnml-nov-delete-article): Update active ranges. + +Tue Feb 4 17:54:09 1997 HISASHIGE Kenji + + * gnus-msg.el (gnus-summary-reply-with-original): Pass on the + `wide' param. + +Tue Feb 4 03:49:59 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.11 is released. + +Tue Feb 4 01:57:56 1997 Lars Magne Ingebrigtsen + + * nnvirtual.el (nnvirtual-last-accessed-component-group): New + variable. + (nnvirtual-request-article): Use it and allow fetching by + Message-ID. + + * gnus-dup.el (gnus-dup-enter-articles): Don't enter canceled + articles into dup lists. + + * nnvirtual.el (nnvirtual-update-read-and-marked): Check that we + have a current group. + + * message.el (message-mode): Add "field" menu under XEmacs. + +Mon Feb 3 07:46:33 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.10 is released. + +Mon Feb 3 05:48:09 1997 Lars Magne Ingebrigtsen + + * message.el (message-fcc-handler-function): Doc fix. + (message-do-fcc): Revert to 5.4.8 behavior. + + * gnus-util.el ((fboundp 'point-at-bol)): Made into defun. + + * gnus-topic.el (gnus-topic-check-topology): Skip "dummy.group". + (gnus-group-sort-topic): Delete "dummy.group". + + * gnus-art.el (article-make-date-line): Add a newline. + + * nnkiboze.el (nnkiboze-generate-group): Check that the nov file + exists. + + * gnus-sum.el (gnus-summary-make-menu-bar): Moved some. + + * gnus-art.el (gnus-article-make-menu-bar): Exclude the summary + menu. + + * gnus.el (gnus-similar-server-opened): New function. + (gnus-server-extend-method): Use it. + + * gnus-sum.el (gnus-data-set-header): New macro. + (gnus-summary-edit-article-done): Update when the Message-ID is + edited. + + * nnml.el (nnml-request-article): Return the correct group name. + +Sat Feb 1 21:29:56 1997 Lars Magne Ingebrigtsen + + * smiley.el (smiley-buffer): Use the `smiley-mouse-face' variable, + not face. + +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 @@ -27,12 +4469,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 @@ -40,1847 +4708,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/ChangeLog.1 --- a/lisp/gnus/ChangeLog.1 Mon Aug 13 09:12: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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/ChangeLog.2 --- a/lisp/gnus/ChangeLog.2 Mon Aug 13 09:12: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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/Makefile --- a/lisp/gnus/Makefile Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/Makefile Mon Aug 13 09:13:56 2007 +0200 @@ -1,10 +1,16 @@ SHELL = /bin/sh EMACS=emacs -FLAGS=-batch -q -no-site-file -l bytecomp -l ./dgnushack.el +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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/custom-opt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/custom-opt.el Mon Aug 13 09:13:56 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.24 +;; 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/custom.el --- a/lisp/gnus/custom.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2400 +0,0 @@ -;;; 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. - -;;; 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'. -;; -;; 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. - -;;; 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)) - -(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))) - -(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)))) - -(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)) - -;; 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.") - -;; 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)) - - (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.") - -(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) - -(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. - -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)... )... )'.") - -(defconst custom-local-type-properties nil - "Local type properties. -Entries in this list take precedence over `custom-type-properties'.") - -(make-variable-buffer-local 'custom-local-type-properties) - -(defconst custom-nil '__uninitialized__ - "Special value representing an uninitialized field.") - -(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))))) - -(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)) - -(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. - -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)) - -(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)))) - -(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)))) - -(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: - -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)) - -(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))) - -(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) - -(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)) - -(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)) - -(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)) - -(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))) - -(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. - -(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)))) - -(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)))) - -(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)) - -(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)) - -(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)))) - -(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))) - -(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)) - -(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)))) - -(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))) - -(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))) - -(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)) - -(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)) - -(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))))) - -(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-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-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-choice-extract (custom field) - "Extract child's value." - (let ((value (custom-field-value field))) - (custom-field-extract (custom-field-custom value) value))) - -(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-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-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))))) - -(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)))) - -(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-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") - -(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-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)))) - -(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)))) - -;;; 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)) - -(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)))) - -(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 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. - -(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)) - -;; 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-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))) - -(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-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-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)))))) - -(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)))) - -(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)))) - -(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. - -(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)))) - -(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)))) - -(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))) - -(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) - -(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)))) - -(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)))))) - -(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))) - -(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)))) - -(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)) - -(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: - -(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))))) - -;; custom.el uses two categories. - -(custom-category-create 'custom-documentation-properties) -(custom-category-put 'custom-documentation-properties rear-nonsticky t) - -(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)) - -(provide 'custom) - -;;; custom.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/dgnushack.el --- a/lisp/gnus/dgnushack.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/dgnushack.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/earcon.el --- a/lisp/gnus/earcon.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/earcon.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-art.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-art.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,2999 @@ +;;; 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 (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 (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) + (concat + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + "\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 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))))) + ;; 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 nil + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-async.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-async.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-audio.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-audio.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-bcklg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-bcklg.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-cache.el --- a/lisp/gnus/gnus-cache.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-cache.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-cite.el --- a/lisp/gnus/gnus-cite.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-cite.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-cus.el --- a/lisp/gnus/gnus-cus.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-cus.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-demon.el --- a/lisp/gnus/gnus-demon.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-demon.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-dup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-dup.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,158 @@ +;;; 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) + (not (= (gnus-data-mark datum) gnus-canceled-mark)) + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-edit.el --- a/lisp/gnus/gnus-edit.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,630 +0,0 @@ -;;; gnus-edit.el --- Gnus SCORE file editing -;; Copyright (C) 1995,96 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen -;; Keywords: news, help -;; Version: 0.2 - -;;; Commentary: -;; -;; Type `M-x gnus-score-customize RET' to invoke. - -;;; Code: - -(require 'custom) -(require 'gnus-score) -(eval-when-compile (require 'cl)) - -(defconst gnus-score-custom-data - '((tag . "Score") - (doc . "Customization of Gnus SCORE files. - -SCORE files allow you to assign a score to each article when you enter -a group, and automatically mark the articles as read or delete them -based on the score. In the summary buffer you can use the score to -sort the articles by score (`C-c C-s C-s') or to jump to the unread -article with the highest score (`,').") - (type . group) - (data "\n" - ((header . nil) - (doc . "Name of SCORE file to customize. - -Enter the name in the `File' field, then push the [Load] button to -load it. When done editing, push the [Save] button to save the file. - -Several score files may apply to each group, and several groups may -use the same score file. This is controlled implicitly by the name of -the score file and the value of the global variable -`gnus-score-find-score-files-function', and explicitly by the -`Files' and `Exclude Files' entries.") - (compact . t) - (type . group) - (data ((tag . "Load") - (type . button) - (query . gnus-score-custom-load)) - ((tag . "Save") - (type . button) - (query . gnus-score-custom-save)) - ((name . file) - (tag . "File") - (directory . gnus-kill-files-directory) - (default-file . "SCORE") - (type . file)))) - ((name . files) - (tag . "Files") - (doc . "\ -List of score files to load when the current score file is loaded. -You can use this to share score entries between multiple score files. - -Push the `[INS]' button add a score file to the list, or `[DEL]' to -delete a score file from the list.") - (type . list) - (data ((type . repeat) - (header . nil) - (data (type . file) - (directory . gnus-kill-files-directory))))) - ((name . exclude-files) - (tag . "Exclude Files") - (doc . "\ -List of score files to exclude when the current score file is loaded. -You can use this if you have a score file you want to share between a -number of newsgroups, except for the newsgroup this score file -matches. [ Did anyone get that? ] - -Push the `[INS]' button add a score file to the list, or `[DEL]' to -delete a score file from the list.") - (type . list) - (data ((type . repeat) - (header . nil) - (data (type . file) - (directory . gnus-kill-files-directory))))) - ((name . mark) - (tag . "Mark") - (doc . "\ -Articles below this score will be automatically marked as read. - -This means that when you enter the summary buffer, the articles will -be shown but will already be marked as read. You can then press `x' -to get rid of them entirely. - -By default articles with a negative score will be marked as read. To -change this, push the `Mark' button, and choose `Integer'. You can -then enter a value in the `Mark' field.") - (type . gnus-score-custom-maybe-type)) - ((name . expunge) - (tag . "Expunge") - (doc . "\ -Articles below this score will not be shown in the summary buffer.") - (type . gnus-score-custom-maybe-type)) - ((name . mark-and-expunge) - (tag . "Mark and Expunge") - (doc . "\ -Articles below this score will be marked as read, but not shown. - -Someone should explain me the difference between this and `expunge' -alone or combined with `mark'.") - (type . gnus-score-custom-maybe-type)) - ((name . eval) - (tag . "Eval") - (doc . "\ -Evaluate this lisp expression when the entering summary buffer.") - (type . sexp)) - ((name . read-only) - (tag . "Read Only") - (doc . "Read-only score files will not be updated or saved. -Except from this buffer, of course!") - (type . toggle)) - ((type . doc) - (doc . "\ -Each news header has an associated list of score entries. -You can use the [INS] buttons to add new score entries anywhere in the -list, or the [DEL] buttons to delete specific score entries. - -Each score entry should specify a string that should be matched with -the content actual header in order to determine whether the entry -applies to that header. Enter that string in the `Match' field. - -If the score entry matches, the articles score will be adjusted with -some amount. Enter that amount in the in the `Score' field. You -should specify a positive amount for score entries that matches -articles you find interesting, and a negative amount for score entries -matching articles you would rather avoid. The final score for the -article will be the sum of the score of all score entries that match -the article. - -The score entry can be either permanent or expirable. To make the -entry permanent, push the `Date' button and choose the `Permanent' -entry. To make the entry expirable, choose instead the `Integer' -entry. After choosing the you can enter the date the score entry was -last matched in the `Date' field. The date will be automatically -updated each time the score entry matches an article. When the date -become too old, the score entry will be removed. - -For your convenience, the date is specified as the number of days -elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 -BC. - -Finally, you can choose what kind of match you want to perform by -pushing the `Type' button. For most entries you can choose between -`Exact' which mean the header content must be exactly identical to the -match string, or `Substring' meaning the match string should be -somewhere in the header content, or even `Regexp' to use Emacs regular -expression matching. The last choice is `Fuzzy' which is like `Exact' -except that whitespace derivations, a beginning `Re:' or a terminating -parenthetical remark are all ignored. Each of the four types have a -variant which will ignore case in the comparison. That variant is -indicated with a `(fold)' after its name.")) - ((name . from) - (tag . "From") - (doc . "Scoring based on the authors email address.") - (type . gnus-score-custom-string-type)) - ((name . subject) - (tag . "Subject") - (doc . "Scoring based on the articles subject.") - (type . gnus-score-custom-string-type)) - ((name . followup) - (tag . "Followup") - (doc . "Scoring based on who the article is a followup to. - -If you want to see all followups to your own articles, add an entry -with a positive score matching your email address here. You can also -put an entry with a negative score matching someone who is so annoying -that you don't even want to see him quoted in followups.") - (type . gnus-score-custom-string-type)) - ((name . xref) - (tag . "Xref") - (doc . "Scoring based on article crossposting. - -If you want to score based on which newsgroups an article is posted -to, this is the header to use. The syntax is a little different from -the `Newsgroups' header, but scoring in `Xref' is much faster. As an -example, to match all crossposted articles match on `:.*:' using the -`Regexp' type.") - (type . gnus-score-custom-string-type)) - ((name . references) - (tag . "References") - (doc . "Scoring based on article references. - -The `References' header gives you an alternative way to score on -followups. If you for example want to see follow all discussions -where people from `iesd.auc.dk' school participate, you can add a -substring match on `iesd.auc.dk>' on this header.") - (type . gnus-score-custom-string-type)) - ((name . message-id) - (tag . "Message-ID") - (doc . "Scoring based on the articles message-id. - -This isn't very useful, but Lars like completeness. You can use it to -match all messaged generated by recent Gnus version with a `Substring' -match on `.fsf@'.") - (type . gnus-score-custom-string-type)) - ((type . doc) - (doc . "\ -WARNING: Scoring on the following three pseudo headers is very slow! -Scoring on any of the real headers use a technique that avoids -scanning the entire article, only the actual headers you score on are -scanned, and this scanning has been heavily optimized. Using just a -single entry for one the three pseudo-headers `Head', `Body', and -`All' will require GNUS to retrieve and scan the entire article, which -can be very slow on large groups. However, if you add one entry for -any of these headers, you can just as well add several. Each -subsequent entry cost relatively little extra time.")) - ((name . head) - (tag . "Head") - (doc . "Scoring based on the article header. - -Instead of matching the content of a single header, the entire header -section of the article is matched. You can use this to match on -arbitrary headers, foe example to single out TIN lusers, use a substring -match on `Newsreader: TIN'. That should get 'em!") - (type . gnus-score-custom-string-type)) - ((name . body) - (tag . "Body") - (doc . "Scoring based on the article body. - -If you think any article that mentions `Kibo' is inherently -interesting, do a substring match on His name. You Are Allowed.") - (type . gnus-score-custom-string-type)) - ((name . all) - (tag . "All") - (doc . "Scoring based on the whole article.") - (type . gnus-score-custom-string-type)) - ((name . date) - (tag . "Date") - (doc . "Scoring based on article date. - -You can change the score of articles that have been posted before, -after, or at a specific date. You should add the date in the `Match' -field, and then select `before', `after', or `at' by pushing the -`Type' button. Imagine you want to lower the score of very old -articles, or want to raise the score of articles from the future (such -things happen!). Then you can't use date scoring for that. In fact, -I can't imagine anything you would want to use this for. - -For your convenience, the date is specified in Usenet date format.") - (type . gnus-score-custom-date-type)) - ((type . doc) - (doc . "\ -The Lines and Chars headers use integer based scoring. - -This means that you should write an integer in the `Match' field, and -the push the `Type' field to if the `Chars' or `Lines' header should -be larger, equal, or smaller than the number you wrote in the match -field.")) - ((name . chars) - (tag . "Characters") - (doc . "Scoring based on the number of characters in the article.") - (type . gnus-score-custom-integer-type)) - ((name . lines) - (tag . "Lines") - (doc . "Scoring based on the number of lines in the article.") - (type . gnus-score-custom-integer-type)) - ((name . orphan) - (tag . "Orphan") - (doc . "Score to add to articles with no parents.") - (type . gnus-score-custom-maybe-type)) - ((name . adapt) - (tag . "Adapt") - (doc . "Adapting the score files to your newsreading habits. - -When you have finished reading a group GNUS can automatically create -new score entries based on which articles you read and which you -skipped. This is normally controlled by the two global variables -`gnus-use-adaptive-scoring' and `gnus-default-adaptive-score-alist', -The first determines whether adaptive scoring should be enabled or -not, while the second determines what score entries should be created. - -You can overwrite the setting of `gnus-use-adaptive-scoring' by -selecting `Enable' or `Disable' by pressing the `Adapt' button. -Selecting `Custom' will allow you to specify the exact adaptation -rules (overwriting `gnus-default-adaptive-score-alist').") - (type . choice) - (data ((tag . "Default") - (default . nil) - (type . const)) - ((tag . "Enable") - (default . t) - (type . const)) - ((tag . "Disable") - (default . ignore) - (type . const)) - ((tag . "Custom") - (doc . "Customization of adaptive scoring. - -Each time you read an article it will be marked as read. Likewise, if -you delete it, it will be marked as deleted, and if you tick it, it will -be marked as ticked. When you leave a group, GNUS can automatically -create score file entries based on these marks, so next time you enter -the group articles with subjects that you read last time have higher -score and articles with subjects that deleted will have lower score. - -Below is a list of such marks. You can insert new marks to the list -by pushing on one of the `[INS]' buttons in the left margin to create -a new entry and then pushing the `Mark' button to select the mark. -For each mark there is another list, this time of article headers, -which determine how the mark should affect that header. The `[INS]' -buttons of this list are indented to indicate that the belong to the -mark above. Push the `Header' button to choose a header, and then -enter a score value in the `Score' field. - -For each article that are marked with `Mark' when you leave the -group, a temporary score entry for the articles `Header' with the -value of `Score' will be added the adapt file. If the score entry -already exists, `Score' will be added to its value. If you understood -that, you are smart. - -You can select the special value `Other' when pressing the `Mark' or -`Header' buttons. This is because Lars might add more useful values -there. If he does, it is up to you to figure out what they are named.") - (type . list) - (default . ((__uninitialized__))) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (header . nil) - (compact . t) - (data ((type . choice) - (tag . "Mark") - (data ((tag . "Unread") - (default . gnus-unread-mark) - (type . const)) - ((tag . "Ticked") - (default . gnus-ticked-mark) - (type . const)) - ((tag . "Dormant") - (default . gnus-dormant-mark) - (type . const)) - ((tag . "Deleted") - (default . gnus-del-mark) - (type . const)) - ((tag . "Read") - (default . gnus-read-mark) - (type . const)) - ((tag . "Expirable") - (default . gnus-expirable-mark) - (type . const)) - ((tag . "Killed") - (default . gnus-killed-mark) - (type . const)) - ((tag . "Kill-file") - (default . gnus-kill-file-mark) - (type . const)) - ((tag . "Low-score") - (default . gnus-low-score-mark) - (type . const)) - ((tag . "Catchup") - (default . gnus-catchup-mark) - (type . const)) - ((tag . "Ancient") - (default . gnus-ancient-mark) - (type . const)) - ((tag . "Canceled") - (default . gnus-canceled-mark) - (type . const)) - ((prompt . "Other") - (default . ??) - (type . sexp)))) - ((type . repeat) - (prefix . " ") - (data . ((type . list) - (compact . t) - (data ((tag . "Header") - (type . choice) - (data ((tag . "Subject") - (default . subject) - (type . const)) - ((prompt . "From") - (tag . "From ") - (default . from) - (type . const)) - ((prompt . "Other") - (width . 7) - (default . nil) - (type . symbol)))) - ((tag . "Score") - (type . integer)))))))))))))) - ((name . local) - (tag . "Local") - (doc . "\ -List of local variables to set when this score file is loaded. - -Using this entry can provide a convenient way to set variables that -will affect the summary mode for only some specific groups, i.e. those -groups matched by the current score file.") - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Name") - (width . 26) - (type . symbol)) - ((tag . "Value") - (width . 26) - (type . sexp))))))))))) - -(defconst gnus-score-custom-type-properties - '((gnus-score-custom-maybe-type - (type . choice) - (data ((type . integer) - (default . 0)) - ((tag . "Default") - (type . const) - (default . nil)))) - (gnus-score-custom-string-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Exact") - (default . E) - (type . const)) - ((tag . "Substring") - (default . S) - (type . const)) - ((tag . "Regexp") - (default . R) - (type . const)) - ((tag . "Fuzzy") - (default . F) - (type . const)) - ((tag . "Exact (fold)") - (default . e) - (type . const)) - ((tag . "Substring (fold)") - (default . s) - (type . const)) - ((tag . "Regexp (fold)") - (default . r) - (type . const)) - ((tag . "Fuzzy (fold)") - (default . f) - (type . const)))))))))) - (gnus-score-custom-integer-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (type . integer)) - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "<") - (default . <) - (type . const)) - ((tag . ">") - (default . >) - (type . const)) - ((tag . "=") - (default . =) - (type . const)) - ((tag . ">=") - (default . >=) - (type . const)) - ((tag . "<=") - (default . <=) - (type . const)))))))))) - (gnus-score-custom-date-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Before") - (default . before) - (type . const)) - ((tag . "After") - (default . after) - (type . const)) - ((tag . "At") - (default . at) - (type . const)))))))))))) - -(defvar gnus-score-custom-file nil - "Name of SCORE file being customized.") - -(defun gnus-score-customize () - "Create a buffer for editing gnus SCORE files." - (interactive) - (let (gnus-score-alist) - (custom-buffer-create "*Score Edit*" gnus-score-custom-data - gnus-score-custom-type-properties - 'gnus-score-custom-set - 'gnus-score-custom-get - 'gnus-score-custom-save)) - (make-local-variable 'gnus-score-custom-file) - (setq gnus-score-custom-file - (expand-file-name "SCORE" gnus-kill-files-directory)) - (make-local-variable 'gnus-score-alist) - (setq gnus-score-alist nil) - (custom-reset-all)) - -(defun gnus-score-custom-get (name) - (if (eq name 'file) - gnus-score-custom-file - (let ((entry (assoc (symbol-name name) gnus-score-alist))) - (if entry - (mapcar 'gnus-score-custom-sanify (cdr entry)) - (setq entry (assoc name gnus-score-alist)) - (if (or (memq name '(files exclude-files local)) - (and (eq name 'adapt) - (not (symbolp (car (cdr entry)))))) - (cdr entry) - (car (cdr entry))))))) - -(defun gnus-score-custom-set (name value) - (cond ((eq name 'file) - (setq gnus-score-custom-file value)) - ((assoc (symbol-name name) gnus-score-alist) - (if value - (setcdr (assoc (symbol-name name) gnus-score-alist) value) - (setq gnus-score-alist (delq (assoc (symbol-name name) - gnus-score-alist) - gnus-score-alist)))) - ((assoc (symbol-name name) gnus-header-index) - (if value - (setq gnus-score-alist - (cons (cons (symbol-name name) value) gnus-score-alist)))) - ((assoc name gnus-score-alist) - (cond ((null value) - (setq gnus-score-alist (delq (assoc name gnus-score-alist) - gnus-score-alist))) - ((and (listp value) (not (eq name 'eval))) - (setcdr (assoc name gnus-score-alist) value)) - (t - (setcdr (assoc name gnus-score-alist) (list value))))) - ((null value)) - ((and (listp value) (not (eq name 'eval))) - (setq gnus-score-alist (cons (cons name value) gnus-score-alist))) - (t - (setq gnus-score-alist - (cons (cons name (list value)) gnus-score-alist))))) - -(defun gnus-score-custom-sanify (entry) - (list (nth 0 entry) - (or (nth 1 entry) gnus-score-interactive-default-score) - (nth 2 entry) - (cond ((null (nth 3 entry)) - 's) - ((memq (nth 3 entry) '(before after at >= <=)) - (nth 3 entry)) - (t - (intern (substring (symbol-name (nth 3 entry)) 0 1)))))) - -(defvar gnus-score-cache nil) - -(defun gnus-score-custom-load () - (interactive) - (let ((file (custom-name-value 'file))) - (if (eq file custom-nil) - (error "You must specify a file name")) - (setq file (expand-file-name file gnus-kill-files-directory)) - (gnus-score-load file) - (setq gnus-score-custom-file file) - (custom-reset-all) - (gnus-message 4 "Loaded"))) - -(defun gnus-score-custom-save () - (interactive) - (custom-apply-all) - (gnus-score-remove-from-cache gnus-score-custom-file) - (let ((file gnus-score-custom-file) - (score gnus-score-alist) - emacs-lisp-mode-hook) - (save-excursion - (set-buffer (get-buffer-create "*Score*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (pp score (current-buffer)) - (gnus-make-directory (file-name-directory file)) - (write-region (point-min) (point-max) file nil 'silent) - (kill-buffer (current-buffer)))) - (gnus-message 4 "Saved")) - -(provide 'gnus-edit) - -;;; gnus-edit.el end here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-eform.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-eform.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-ems.el --- a/lisp/gnus/gnus-ems.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-ems.el Mon Aug 13 09:13:56 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)) @@ -232,6 +195,12 @@ (insert " " gnus-tmp-subject-or-nil "\n")) ))) +(defun gnus-region-active-p () + "Say whether the region is active." + (and (boundp 'transient-mark-mode) + transient-mark-mode + (boundp 'mark-active) + mark-active)) (provide 'gnus-ems) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-gl.el --- a/lisp/gnus/gnus-gl.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-gl.el Mon Aug 13 09:13:56 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)) + (make-local-hook 'gnus-select-article-hook) + (gnus-add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-group.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-group.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,3309 @@ +;;; 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) + (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 (gnus-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 (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-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")) + (ignore-errors + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-int.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-int.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-kill.el --- a/lisp/gnus/gnus-kill.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-kill.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-load.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-load.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-logic.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-logic.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-mh.el --- a/lisp/gnus/gnus-mh.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-mh.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-move.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-move.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-msg.el --- a/lisp/gnus/gnus-msg.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-msg.el Mon Aug 13 09:13:56 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,19 +160,22 @@ (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) - (gnus-make-local-hook 'message-sent-hook) + (make-local-hook 'message-sent-hook) (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) (setq message-post-method `(lambda (arg) @@ -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))) + (gnus-summary-reply (gnus-summary-work-articles n) wide)) -(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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-nocem.el --- a/lisp/gnus/gnus-nocem.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-nocem.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-picon.el --- a/lisp/gnus/gnus-picon.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-picon.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-range.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-range.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-salt.el --- a/lisp/gnus/gnus-salt.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-salt.el Mon Aug 13 09:13:56 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))) @@ -516,11 +677,11 @@ ;; 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) + (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) (- (point) (gnus-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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-score.el --- a/lisp/gnus/gnus-score.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-score.el Mon Aug 13 09:13:56 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,12 +824,13 @@ (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)))) - (beginning-of-line 2))))) + (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)))) + (gnus-set-mode-line 'summary)) (defun gnus-summary-score-crossposting (score date) ;; Enter score file entry for current crossposting. @@ -656,15 +839,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 +908,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 +953,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 +967,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 +992,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 +1012,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 +1030,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 +1046,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 +1077,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 +1098,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 +1113,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 +1146,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 +1171,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 +1227,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 +1246,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 +1320,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 +1350,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 +1384,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 +1411,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 +1430,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 +1453,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 +1480,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 +1498,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 +1521,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 +1529,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 +1579,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 +1596,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 +1615,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 +1650,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 +1704,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 +1720,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 +1766,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 +1804,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 +1817,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) + (= (gnus-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 (= (gnus-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 (gnus-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 +2042,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 +2049,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 +2181,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 +2285,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 +2301,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 +2327,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 +2363,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 +2412,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 +2427,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 +2446,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 +2476,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 +2542,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 +2573,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 +2657,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 +2669,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-setup.el --- a/lisp/gnus/gnus-setup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-setup.el Mon Aug 13 09:13:56 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,12 +29,9 @@ ;; 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)) @@ -84,13 +81,12 @@ "Set this if you want to use Mailcrypt for dealing with PGP messages") (defvar gnus-use-bbdb nil "Set this if you want to use the Big Brother DataBase") -(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))) + (push gnus-gnus-lisp-directory load-path)) +;;; We can't do this until we know where Gnus is. (require 'message) ;;; Tools for MIME by @@ -113,7 +109,7 @@ (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))) + (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,7 +119,7 @@ (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. @@ -169,14 +165,11 @@ (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" "\ Read network news as a slave without connecting to local server." t nil) @@ -186,8 +179,7 @@ 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" "\ Read news as a slave." t nil) @@ -198,21 +190,26 @@ 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) - (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)) -;;;*** - (provide 'gnus-setup) (run-hooks 'gnus-setup-load-hook) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-sound.el --- a/lisp/gnus/gnus-sound.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;; gnus-sound.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: - -(if (null (boundp 'running-xemacs)) - (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) - -(require 'nnheader) -(eval-when-compile (require 'cl)) - -(defvar gnus-sound-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-sound-directory (nnheader-find-etc-directory "sounds") - "The directory containing the Sound Files.") - -(defvar gnus-sound-au-player "/usr/bin/showaudio" - "Executable program for playing sun AU format sound files") -(defvar gnus-sound-wav-player "/usr/local/bin/play" - "Executable program for playing WAV files") - - -;;; The following isn't implemented yet. Wait for Red Gnus. -;(defvar gnus-sound-effects-enabled t -; "When t, Gnus will use sound effects.") -;(defvar gnus-sound-enable-hooks nil -; "Functions run when enabling sound effects.") -;(defvar gnus-sound-disable-hooks nil -; "Functions run when disabling sound effects.") -;(defvar gnus-sound-theme-song nil -; "Theme song for Gnus.") -;(defvar gnus-sound-enter-group nil -; "Sound effect played when selecting a group.") -;(defvar gnus-sound-exit-group nil -; "Sound effect played when exiting a group.") -;(defvar gnus-sound-score-group nil -; "Sound effect played when scoring a group.") -;(defvar gnus-sound-busy-sound nil -; "Sound effect played when going into a ... sequence.") - - -;;;###autoload -;(defun gnus-sound-enable-sound () -; "Enable Sound Effects for Gnus." -; (interactive) -; (setq gnus-sound-effects-enabled t) -; (run-hooks gnus-sound-enable-hooks)) - -;;;###autoload -;(defun gnus-sound-disable-sound () -; "Disable Sound Effects for Gnus." -; (interactive) -; (setq gnus-sound-effects-enabled nil) -; (run-hooks gnus-sound-disable-hooks)) - -;;;###autoload -(defun gnus-sound-play (file) - "Play a sound through the speaker." - (interactive) - (let ((sound-file (if (file-exists-p file) - file - (concat gnus-sound-directory file)))) - (when (file-exists-p sound-file) - (if gnus-sound-inline-sound - (play-sound-file (concat gnus-sound-directory sound-file)) - (cond ((string-match "\\.wav$" sound-file) - (call-process gnus-sound-wav-player - (concat gnus-sound-directory sound-file) - 0 - nil)) - ((string-match "\\.au$" sound-file) - (call-process gnus-sound-au-player - (concat gnus-sound-directory sound-file) - 0 - nil))))))) - - -;;; The following isn't implemented yet, wait for Red Gnus -;(defun gnus-sound-startrek-sounds () -; "Enable sounds from Star Trek the original series." -; (interactive) -; (setq gnus-sound-busy-sound "working.au") -; (setq gnus-sound-enter-group "bulkhead_door.au") -; (setq gnus-sound-exit-group "bulkhead_door.au") -; (setq gnus-sound-score-group "ST_laser.au") -; (setq gnus-sound-theme-song "startrek.au") -; (add-hook 'gnus-select-group-hook 'gnus-sound-startrek-select-group) -; (add-hook 'gnus-exit-group-hook 'gnus-sound-startrek-exit-group)) -;;;*** - -(provide 'gnus-sound) - -(run-hooks 'gnus-sound-load-hook) - -;;; gnus-sound.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-soup.el --- a/lisp/gnus/gnus-soup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-soup.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-spec.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-spec.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-srvr.el --- a/lisp/gnus/gnus-srvr.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-srvr.el Mon Aug 13 09:13:56 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,13 +118,19 @@ "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 - "\C-c\C-i" gnus-info-find-node)) + "g" gnus-server-regenerate-server + + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) (defun gnus-server-mode () "Major mode for listing and editing servers. @@ -132,14 +144,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 +207,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)) @@ -229,7 +242,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 +282,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 +290,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 +342,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 +351,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 +401,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 +423,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 +445,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." @@ -499,24 +513,23 @@ "\C-c\C-c" gnus-browse-exit "?" gnus-browse-describe-briefly - "\C-c\C-i" gnus-info-find-node)) + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) (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 +548,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 +574,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 +614,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 +623,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,7 +666,8 @@ (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 () @@ -665,8 +684,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 +726,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-start.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-start.el Mon Aug 13 09:13:56 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) (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))))) + (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 + (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 () + (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 + (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))) + (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 (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 ", ")) + + ;; 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" (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. + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-sum.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,8540 @@ +;;; 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-ps-print-hook nil + "*A hook run before ps-printing something from Gnus." + :group 'gnus-summary + :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] + ["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] + ["Search articles forward..." gnus-summary-search-article-forward t] + ["Search articles backward..." gnus-summary-search-article-backward 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) + (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-set-header (data header) + `(setf (nth 3 ,data) ,header)) + +(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 (gnus-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 + (- (gnus-point-at-bol) + (prog1 + (1+ (gnus-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) + + (beginning-of-line) + + (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) + + (gnus-update-read-articles group gnus-newsgroup-unreads) + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-group-update-group group)) + + (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 (gnus-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 + (- (gnus-point-at-bol) + (prog1 + (1+ (gnus-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))) + ((gnus-region-active-p) + ;; 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)) + (article-window (get-buffer-window gnus-article-buffer))) + (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) + (when article-window + (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) + (run-hooks 'gnus-ps-print-hook) + (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))) + + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + + (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 the marks 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 ((head (buffer-string)) + header) + (nnheader-temp-write nil + (insert (format "211 %d Article retrieved.\n" + (cdr gnus-article-current))) + (insert head) + (insert ".\n") + (let ((nntp-server-buffer (current-buffer))) + (setq header (car (gnus-get-newsgroup-headers + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies) + t)))) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-data-set-header + (gnus-data-find (cdr gnus-article-current)) + header) + (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) + (set-buffer gnus-original-article-buffer) + (gnus-request-article + (cdr gnus-article-current) (car gnus-article-current) (current-buffer))) + ;; 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]" (gnus-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 (or (not where) + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-topic.el --- a/lisp/gnus/gnus-topic.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-topic.el Mon Aug 13 09:13:56 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,7 +90,7 @@ (defvar gnus-topic-line-format-spec nil) -;; Functions. +;;; Utility functions (defun gnus-group-topic-name () "The name of the topic on the current line." @@ -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 (gnus-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,63 +274,9 @@ (setq topology (cdr topology))) result))) -(gnus-add-shutdown 'gnus-topic-close 'gnus) - -(defun gnus-topic-close () - (setq gnus-topic-active-topology nil - gnus-topic-active-alist nil - gnus-topic-killed-topics nil - gnus-topic-tallied-groups nil - gnus-topology-checked-p nil)) - - -(defun gnus-topic-check-topology () - ;; The first time we set the topology to whatever we have - ;; gotten here, which can be rather random. - (unless gnus-topic-alist - (gnus-topic-init-alist)) - - (setq gnus-topology-checked-p t) - ;; Go through the topic alist and make sure that all topics - ;; are in the topic topology. - (let ((topics (gnus-topic-list)) - (alist gnus-topic-alist) - changed) - (while alist - (unless (member (caar alist) topics) - (nconc gnus-topic-topology - (list (list (list (caar alist) 'visible)))) - (setq changed t)) - (setq alist (cdr alist))) - (when changed - (gnus-topic-enter-dribble)) - ;; Conversely, go through the topology and make sure that all - ;; topologies have alists. - (while topics - (unless (assoc (car topics) gnus-topic-alist) - (push (list (car topics)) gnus-topic-alist)) - (pop topics))) - ;; Go through all living groups and make sure that - ;; they belong to some topic. - (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) - gnus-topic-alist))) - (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) - (newsrc gnus-newsrc-alist) - group) - (while newsrc - (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) - (setcdr entry (cons group (cdr entry)))))) - ;; Go through all topics and make sure they contain only living groups. - (let ((alist gnus-topic-alist) - topic) - (while (setq topic (pop alist)) - (while (cdr topic) - (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) - (setq topic (cdr topic)) - (setcdr topic (cddr topic))))))) - (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)) @@ -433,73 +284,277 @@ (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))) -(defun gnus-topic-articles-in-topic (entries) - (let ((total 0) - number) - (while entries - (when (numberp (setq number (car (pop entries)))) - (incf total number))) - total)) +;;; 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)) -(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)) + (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-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) + (point-max (point-max)) + (unread 0) + (topic (car type)) + info entry end active tick) + ;; Insert any sub-topics. + (while topicl + (incf unread + (gnus-topic-prepare-topic + (pop topicl) (1+ level) list-level 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))) + (when (and (listp entry) + (numberp (car entry))) + (setq tick t))) + (goto-char beg) + ;; Insert the topic line. + (when (and (not silent) + (or gnus-topic-display-empty-topics ;We want empty topics + (not (zerop unread)) ;Non-empty + tick ;Ticked articles + (/= point-max (point-max)))) ;Unactivated groups + (gnus-extent-start-open (point)) + (gnus-topic-insert-topic-line + (car type) visiblep + (not (eq (nth 2 type) 'hidden)) + level all-entries unread)) + (goto-char end) + unread)) -(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-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-group-parent-topic))) + (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) +(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 + ;; 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)) + (when (gnus-group-goto-group (pop g) t) (forward-line 1) (setq unfound nil))) (when unfound @@ -539,6 +594,189 @@ 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 () + (setq gnus-topic-active-topology nil + gnus-topic-active-alist nil + gnus-topic-killed-topics nil + gnus-topic-tallied-groups nil + gnus-topology-checked-p nil)) + +(defun gnus-topic-check-topology () + ;; The first time we set the topology to whatever we have + ;; gotten here, which can be rather random. + (unless gnus-topic-alist + (gnus-topic-init-alist)) + + (setq gnus-topology-checked-p t) + ;; Go through the topic alist and make sure that all topics + ;; are in the topic topology. + (let ((topics (gnus-topic-list)) + (alist gnus-topic-alist) + changed) + (while alist + (unless (member (caar alist) topics) + (nconc gnus-topic-topology + (list (list (list (caar alist) 'visible)))) + (setq changed t)) + (setq alist (cdr alist))) + (when changed + (gnus-topic-enter-dribble)) + ;; Conversely, go through the topology and make sure that all + ;; topologies have alists. + (while topics + (unless (assoc (car topics) gnus-topic-alist) + (push (list (car topics)) gnus-topic-alist)) + (pop topics))) + ;; Go through all living groups and make sure that + ;; they belong to some topic. + (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) + gnus-topic-alist))) + (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) + (newsrc (cdr gnus-newsrc-alist)) + group) + (while newsrc + (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) + (setcdr entry (cons group (cdr entry)))))) + ;; Go through all topics and make sure they contain only living groups. + (let ((alist gnus-topic-alist) + topic) + (while (setq topic (pop alist)) + (while (cdr topic) + (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) + (setq topic (cdr topic)) + (setcdr topic (cddr topic))))))) + +(defun gnus-topic-init-alist () + "Initialize the topic structures." + (setq gnus-topic-topology + (cons (list "Gnus" 'visible) + (mapcar (lambda (topic) + (list (list (car topic) 'visible))) + '(("misc"))))) + (setq gnus-topic-alist + (list (cons "misc" + (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist))) + (list "Gnus"))) + (gnus-topic-enter-dribble)) + +;;; Maintenance + +(defun gnus-topic-clean-alist () + "Remove bogus groups from the topic alist." + (let ((topic-alist gnus-topic-alist) + result topic) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (while (setq topic (pop topic-alist)) + (let ((topic-name (pop topic)) + group filtered-topic) + (while (setq group (pop topic)) + (when (and (or (gnus-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-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-next-group (group props) + "Go to group or the next group after group." + (if (not group) + (if (not (memq 'gnus-topic props)) + (goto-char (point-max)) + (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))) + (if (gnus-group-goto-group group) + t + ;; The group is no longer visible. + (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) + (after (cdr (member group (cdr list))))) + ;; First try to put point on a group after the current one. + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after))) + ;; Then try to put point on a group before point. + (unless after + (setq after (cdr (member group (reverse (cdr list))))) + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after)))) + ;; Finally, just put point on the topic. + (if (not (car list)) + (goto-char (point-min)) + (unless after + (gnus-topic-goto-topic (car list)) + (setq after nil))) + t)))) + +;;; Topic-active functions + (defun gnus-topic-grok-active (&optional force) "Parse all active groups and create topic structures for them." ;; First we make sure that we have really read the active file. @@ -589,12 +827,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 +836,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 +907,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,18 +919,21 @@ 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) + (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) ;; We check the topology. @@ -702,7 +946,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 +991,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 +1022,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 +1060,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 +1079,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 +1097,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 +1108,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 +1126,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 +1138,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 +1203,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 +1213,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 +1222,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 +1248,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 +1267,96 @@ 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))) + (setcar alist (delete "dummy.group" (car alist))) + (gnus-topic-sort-topic (pop alist) func reverse)))) + +(defun gnus-topic-sort-topic (topic func reverse) + ;; Each topic only lists the name of the group, while + ;; the sort predicates expect group infos as inputs. + ;; So we first transform the group names into infos, + ;; then sort, and then transform back into group names. + (setcdr + topic + (mapcar + (lambda (info) (gnus-info-group info)) + (sort + (mapcar + (lambda (group) (gnus-get-info group)) + (cdr topic)) + func))) + ;; Do the reversal, if necessary. + (when reverse + (setcdr topic (nreverse (cdr topic))))) + +(defun gnus-topic-sort-groups (func &optional reverse) + "Sort the current topic according to FUNC. +If REVERSE, reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) + (gnus-topic-sort-topic + topic (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-topic-sort-groups-by-alphabet (&optional reverse) + "Sort the current topic alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-topic-sort-groups-by-unread (&optional reverse) + "Sort the current topic by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-topic-sort-groups-by-level (&optional reverse) + "Sort the current topic by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-topic-sort-groups-by-score (&optional reverse) + "Sort the current topic by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-topic-sort-groups-by-rank (&optional reverse) + "Sort the current topic by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-topic-sort-groups-by-method (&optional reverse) + "Sort the current topic alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) + (provide 'gnus-topic) ;;; gnus-topic.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-undo.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-undo.el Mon Aug 13 09:13:56 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)) + (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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-util.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,819 @@ +;;; 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: + +(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)))) + +(if (fboundp 'point-at-bol) + (fset 'gnus-point-at-bol 'point-at-bol) + (defun 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) + (defun 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-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 ":" (gnus-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 menu 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-y-or-n-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (save-excursion + (set-buffer file-buffer) + (let ((require-final-newline nil)) + (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) + (let ((buffer-read-only nil)) + (save-excursion + (goto-char (point-max)) + (forward-char -2) + (unless (looking-at "\n\n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n")) + (goto-char (point-max)) + (append-to-file (point-min) (point-max) filename))) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (unless (eobp) + (insert "\n")) + (insert "\n") + (insert-buffer-substring tmpbuf))))) + (kill-buffer tmpbuf))) + +(defun gnus-convert-article-to-rmail () + "Convert article in current buffer to Rmail message format." + (let ((buffer-read-only nil)) + ;; Convert article directly into Babyl format. + (goto-char (point-min)) + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (while (search-forward "\n\^_" nil t) ;single char + (replace-match "\n^_" t t)) ;2 chars: "^" and "_" + (goto-char (point-max)) + (insert "\^_"))) + +(provide 'gnus-util) + +;;; gnus-util.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-uu.el --- a/lisp/gnus/gnus-uu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 09:13:56 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,43 +503,45 @@ "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) - (setq gnus-uu-digest-from-subject nil) - (gnus-uu-decode-save n file) - (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) - (gnus-add-current-to-buffer-list) - (erase-buffer) - (delete-other-windows) - (insert-file file) - (let ((fs gnus-uu-digest-from-subject)) - (if (not 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))) - (setq fs (cdr fs)))) - (or subject (setq subject "Digested Articles")) - (or from (setq from "Various"))) - (goto-char (point-min)) - (and (re-search-forward "^Subject: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert subject))) - (goto-char (point-min)) - (and (re-search-forward "^From: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert from))) - (message-forward post) + (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) + buf subject from newsgroups) + (gnus-setup-message 'forward + (setq gnus-uu-digest-from-subject nil) + (gnus-uu-decode-save n file) + (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) + (gnus-add-current-to-buffer-list) + (erase-buffer) + (insert-file file) + (let ((fs gnus-uu-digest-from-subject)) + (when fs + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (when from + (unless (string= from (caar fs)) + (setq from nil))) + (when subject + (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) + (goto-char (point-min)) + (when (re-search-forward "^Subject: ") + (delete-region (point) (gnus-point-at-eol)) + (insert subject)) + (goto-char (point-min)) + (when (re-search-forward "^From: ") + (delete-region (point) (gnus-point-at-eol)) + (insert from)) + (message-forward post)) (delete-file file) (kill-buffer buf) (setq gnus-uu-digest-from-subject nil))) @@ -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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-vis.el --- a/lisp/gnus/gnus-vis.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1607 +0,0 @@ -;;; gnus-vis.el --- display-oriented parts of Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Per Abrahamsen -;; 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-ems) -(require 'easymenu) -(require 'custom) -(require 'browse-url) -(require 'gnus-score) -(eval-when-compile (require 'cl)) - -(defvar gnus-group-menu-hook nil - "*Hook run after the creation of the group mode menu.") - -(defvar gnus-summary-menu-hook nil - "*Hook run after the creation of the summary mode menu.") - -(defvar gnus-article-menu-hook nil - "*Hook run after the creation of the article mode menu.") - -;;; Summary highlights. - -;(defvar gnus-summary-highlight-properties -; '((unread "ForestGreen" "green") -; (ticked "Firebrick" "pink") -; (read "black" "white") -; (low italic italic) -; (high bold bold) -; (canceled "yellow/black" "black/yellow"))) - -;(defvar gnus-summary-highlight-translation -; '(((unread (= mark gnus-unread-mark)) -; (ticked (or (= mark gnus-ticked-mark) (= mark gnus-dormant-mark))) -; (read (not (or (= mark gnus-unread-mark) (= mark gnus-dormant-mark) -; (= mark gnus-ticked-mark) (= mark gnus-canceled-mark)))) -; (canceled (= mark gnus-canceled-mark))) -; ((low (< score gnus-summary-default-score)) -; (high (> score gnus-summary-default-score))))) - -;(defun gnus-visual-map-face-translation () -; (let ((props gnus-summary-highlight-properties) -; (trans gnus-summary-highlight-translation) -; map) -; (while props))) - -;see gnus-cus.el -;(defvar gnus-summary-selected-face 'underline -; "*Face used for highlighting the current article in the summary buffer.") - -;see gnus-cus.el -;(defvar gnus-summary-highlight -; (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)) - -; (cons '(and (> score default) (= mark gnus-ancient-mark)) -; (custom-face-lookup "SkyBlue" 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)) - -; (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)) - -; (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)))) -; "*Alist of `(FORM . FACE)'. -;Summary lines are highlighted with the FACE for the first FORM which -;evaluate to a non-nil value. - -;Point will be at the beginning of the line when FORM is evaluated. -;The following can be used for convenience: - -;score: (gnus-summary-article-score) -;default: gnus-summary-default-score -;below: gnus-summary-mark-below -;mark: (gnus-summary-article-mark) - -;The latter can be used like this: -; ((= mark gnus-replied-mark) . underline)") - -;;; article highlights - -;see gnus-cus.el -;(defvar gnus-header-face-alist -; (cond ((not (eq gnus-display-type 'color)) -; '(("" bold italic))) -; ((eq gnus-background-mode 'dark) -; (list (list "From" nil -; (custom-face-lookup "SkyBlue" 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 "green" nil nil nil t nil)))) -; (t -; (list (list "From" nil -; (custom-face-lookup "RoyalBlue" nil nil t t nil)) -; (list "Subject" nil -; (custom-face-lookup "firebrick" nil nil t t nil)) -; (list "Newsgroups:.*," nil -; (custom-face-lookup "red" nil nil t t nil)) -; (list "" -; (custom-face-lookup "DarkGreen" nil nil t nil nil) -; (custom-face-lookup "DarkGreen" nil nil nil t nil))))) -; "Alist of headers and faces used for highlighting them. -;The entries in the list has the form `(REGEXP NAME CONTENT)', where -;REGEXP is a regular expression matching the beginning of the header, -;NAME is the face used for highlighting the header name and CONTENT is -;the face used for highlighting the header content. - -;The first non-nil NAME or CONTENT with a matching REGEXP in the list -;will be used.") - - -;see gnus-cus.el -;(defvar gnus-make-foreground t -; "Non nil means foreground color to highlight citations.") - -;see gnus-cus.el -;(defvar gnus-article-button-face 'bold -; "Face used for text buttons.") - -;see gnus-cus.el -;(defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face) -; gnus-mouse-face -; 'highlight) -; "Face used when the mouse is over the button.") - -;see gnus-cus.el -;(defvar gnus-signature-face 'italic -; "Face used for signature.") - -(defvar gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]" - "*Regular expression that matches URLs.") - -(defvar gnus-button-alist - `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 - t gnus-button-message-id 3) - ("\\(\n\t ]*\\)>?\\)" 1 t - gnus-button-message-id 3) - ("\\( \n\t]+\\)>?" 0 t gnus-button-reply 2) - ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 0 t gnus-button-url 1) - ;; Next regexp stolen from highlight-headers.el. - ;; Modified by Vladimir Alexiev. - (,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.") - -(defvar 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'.") - -;see gnus-cus.el -;(eval-when-compile -; (defvar browse-url-browser-function)) - -;;; Group mode highlighting. - -;see gnus-cus.el -;(defvar gnus-group-highlight nil -; "Group lines are highlighted with the FACE for the first FORM which -;evaluate to a non-nil value. -; -;Point will be at the beginning of the line when FORM is evaluated. -;Variables bound when these forms are evaluated include: -; -;group: The group name. -;unread: The number of unread articles. -;method: The select method. -;mailp: Whether the select method is a mail method. -;level: The level of the group. -;score: The score of the group. -;ticked: The number of ticked articles in the group. -;") - - -;;; Internal variables. - -(defvar gnus-button-marker-list nil) - - - -(eval-and-compile - (autoload 'nnkiboze-generate-groups "nnkiboze") - (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t)) - -;;; -;;; gnus-menu -;;; - -(defun gnus-visual-turn-off-edit-menu (type) - (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) - [menu-bar edit] 'undefined)) - -;; Newsgroup buffer - -(defun gnus-group-make-menu-bar () - (gnus-visual-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)] - ["Edit kill file" gnus-group-edit-local-kill - (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)] - )) - - (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 - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by method" gnus-group-sort-groups-by-method - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by rank" gnus-group-sort-groups-by-rank - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by score" gnus-group-sort-groups-by-score - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by level" gnus-group-sort-groups-by-level - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by unread" gnus-group-sort-groups-by-unread - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] - ["Sort by name" gnus-group-sort-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 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))]) - ("Editing groups" - ["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)]) - ("Score file" - ["Flush cache" gnus-score-flush-cache - (or gnus-score-cache gnus-short-name-score-file-cache)]) - ("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-previous-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]) - ["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" - ["Send a bug report" gnus-bug t] - ["Send a mail" gnus-group-mail t] - ["Post an article..." gnus-group-post-news t] - ["Customize score file" gnus-score-customize t] - ["Check for new news" gnus-group-get-new-news t] - ["Activate all groups" gnus-activate-all-groups t] - ["Delete bogus groups" gnus-group-check-bogus-groups t] - ["Find new newsgroups" gnus-find-new-newsgroups 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] - ["Edit global kill file" gnus-group-edit-global-kill t] - ["Read manual" gnus-info-find-node t] - ["Toggle topics" gnus-topic-mode t] - ("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)]) - ["Exit from Gnus" gnus-group-exit t] - ["Exit without saving" gnus-group-quit t] - )) - - (run-hooks 'gnus-group-menu-hook) - )) - -;; Summary buffer -(defun gnus-summary-make-menu-bar () - (gnus-visual-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]) - (gnus-visual-score-map 'increase) - (gnus-visual-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] - ["Customize score file" gnus-score-customize 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] - ["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]) - ("Filter" - ["Overstrike" gnus-article-treat-overstrike t] - ["Word wrap" gnus-article-fill-cited-article t] - ["CR" gnus-article-remove-cr t] - ["Trailing blank lines" gnus-article-remove-trailing-blank-lines 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] - ["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] - ["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]) - ("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] - ["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]) - ["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] - ["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] - ;;("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]) - ("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]) - ("Limit" - ["Marks..." gnus-summary-limit-to-marks t] - ["Subject..." gnus-summary-limit-to-subject t] - ["Author..." gnus-summary-limit-to-author 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])) - ("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]) - ("Help" - ["Fetch group FAQ" gnus-summary-fetch-faq t] - ["Describe group" gnus-summary-describe-group t] - ["Read manual" gnus-info-find-node t]) - ("Cache" - ["Enter article" gnus-cache-enter-article t] - ["Remove article" gnus-cache-remove-article t]) - ("Modes" - ["Pick and read" gnus-pick-mode t] - ["Binary" gnus-binary-mode 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]))) - - (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-visual-score-map (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)))))))) - -;; Article buffer -(defun gnus-article-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'summary) - (or - (boundp 'gnus-article-article-menu) - (progn - (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] - )) - (run-hooks 'gnus-article-menu-hook)))) - -;;; -;;; summary highlights -;;; - -(defun gnus-highlight-selected-summary () - ;; Added by Per Abrahamsen . - ;; Highlight selected article in summary buffer - (if 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 - (1+ (or (next-single-property-change - beg gnus-mouse-face-prop nil end) - beg)))) - (to (1- (or (next-single-property-change - from gnus-mouse-face-prop nil end) - end)))) - ;; If no mouse-face prop on line (e.g. xemacs) we - ;; will have to = from = end, so we highlight the - ;; entire line instead. - (if (= (+ to 2) from) - (progn - (setq from beg) - (setq to end))) - (if gnus-newsgroup-selected-overlay - (gnus-move-overlay gnus-newsgroup-selected-overlay - from to (current-buffer)) - (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) - (gnus-overlay-put gnus-newsgroup-selected-overlay '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-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)) - (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)))) - (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))) - -;;; -;;; 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)) - -;;; -;;; article highlights -;;; - -;; Written by Per Abrahamsen . - -;;; Internal Variables: - -(defvar gnus-button-regexp 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))) - (if 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))) - (if 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)) - (or (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-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) - 'face gnus-signature-face) - (widen) - (re-search-backward gnus-signature-separator nil t) - (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 (or (eq t (nth 1 entry)) - (eval (nth 1 entry))) - ;; 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* ((from (match-beginning 0)) - (entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (and (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." - (and 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-unhide-text end (point-max)) - (gnus-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 (buffer-substring - (match-beginning group) - (match-end 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-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)) - -;;; 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))) - -;;; Compatibility Functions: - -(or (fboundp 'rassoc) - ;; Introduced in Emacs 19.29. - (defun rassoc (elt list) - "Return non-nil if ELT is `equal' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr is ELT." - (let (result) - (while list - (setq result (car list)) - (if (equal (cdr result) elt) - (setq list nil) - (setq result nil - list (cdr list)))) - result))) - -; (require 'gnus-cus) -(gnus-ems-redefine) -(provide 'gnus-vis) - -;;; gnus-vis.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-vm.el --- a/lisp/gnus/gnus-vm.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-vm.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-win.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-win.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus-xmas.el --- a/lisp/gnus/gnus-xmas.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus-xmas.el Mon Aug 13 09:13:56 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))) (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) @@ -384,10 +399,14 @@ (require 'text-props) (if (and (<= emacs-major-version 19) - (< emacs-minor-version 14)) + (< 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) @@ -407,58 +426,17 @@ (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'. + (make-color-instance color)))))) -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.") - ) - - +(defun gnus-xmas-region-active-p () + (and (fboundp 'region-active-p) + (region-active-p))) (defun gnus-xmas-redefine () "Redefine lots of Gnus functions for XEmacs." @@ -475,19 +453,20 @@ (fset 'gnus-appt-select-lowest-window 'gnus-xmas-appt-select-lowest-window) (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) - (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) + (fset 'gnus-region-active-p 'gnus-xmas-region-active-p) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) (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) @@ -499,7 +478,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 @@ -508,8 +488,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. @@ -571,7 +550,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) @@ -581,13 +560,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. @@ -601,22 +578,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"] @@ -643,6 +620,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"] @@ -656,7 +635,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"] @@ -672,6 +651,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"] @@ -736,36 +717,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/gnus.el --- a/lisp/gnus/gnus.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/gnus.el Mon Aug 13 09:13:56 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,592 @@ (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.12" "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-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 +621,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 +665,1376 @@ (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. Note that the default of nil is unlikely +to be desirable; see the manual for further details." + :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 "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." @@ -15519,19 +2351,28 @@ ;; "hello", and the select method is ("hello" (my-var "something")) ;; in the group "alt.alt", this will result in a new virtual server ;; called "hello+alt.alt". - (let ((entry - (gnus-copy-sequence - (if (equal (car method) "native") gnus-select-method - (cdr (assoc (car method) gnus-server-alist)))))) - (setcar (cdr entry) (concat (nth 1 entry) "+" group)) - (nconc entry (cdr method)))) + (if (or (not (gnus-similar-server-opened method)) + (not (cddr method))) + method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method)))) + +(defun gnus-similar-server-opened (method) + (let ((opened gnus-opened-servers)) + (while (and method opened) + (when (and (equal (cadr method) (cadaar opened)) + (not (equal method (caar opened)))) + (setq method nil)) + (pop opened)) + (not 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) @@ -15554,7 +2395,7 @@ (setq method (cond ((stringp method) (gnus-server-to-method method)) - ((stringp (car method)) + ((stringp (cadr method)) (gnus-server-extend-method group method)) (t method))) @@ -15566,1800 +2407,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/lpath.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/lpath.el Mon Aug 13 09:13:56 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 + 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 characterp display-error))) + +(setq load-path (cons "." load-path)) +(require 'custom) + +(provide 'lpath) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/mailheader.el --- a/lisp/gnus/mailheader.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/mailheader.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/md5.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/md5.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/message.el --- a/lisp/gnus/message.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/message.el Mon Aug 13 09:13:56 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 `message-output' which saves in Unix +mailbox format." + :type '(radio (function-item message-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,361 @@ 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) + (stringp gnus-local-organization) gnus-local-organization) (getenv "ORGANIZATION") t) "*String to be used as an Organization header. -If t, use `message-user-organization-file'.") +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 +532,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 +568,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-mh-deletable-headers '(Message-ID Date Lines Sender) + "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 +612,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 +625,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 +719,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 +752,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 +764,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)))) - -(defun message-fetch-field (header) + (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 &optional not-all) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header))) + (let ((value (mail-fetch-field header nil (not not-all)))) (when value (nnheader-replace-chars-in-string value ?\n ? )))) @@ -630,19 +886,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 +921,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 +987,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 +1036,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,15 +1047,16 @@ 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) (setq message-reply-buffer nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) - (make-local-variable 'message-kill-actions) - (make-local-variable 'message-postpone-actions) + (set (make-local-variable 'message-send-actions) nil) + (set (make-local-variable 'message-exit-actions) nil) + (set (make-local-variable 'message-kill-actions) nil) + (set (make-local-variable 'message-postpone-actions) nil) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) (setq local-abbrev-table message-mode-abbrev-table) @@ -834,6 +1099,7 @@ (when (string-match "XEmacs\\|Lucid" emacs-version) (message-setup-toolbar)) (easy-menu-add message-mode-menu message-mode-map) + (easy-menu-add message-mode-field-menu message-mode-map) ;; Allow mail alias things. (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) @@ -914,14 +1180,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 +1217,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 +1240,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 +1251,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 +1313,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 +1335,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 +1346,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 +1377,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 +1398,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 +1424,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 +1479,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 +1518,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 +1603,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 +1671,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 +1690,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 +1717,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-mh-deletable-headers + (let ((headers message-mh-deletable-headers)) + (while headers + (goto-char (point-min)) + (and (re-search-forward + (concat "^" (symbol-name (car headers)) ": *") nil t) + (message-delete-line)) + (pop headers)))) + (run-hooks 'message-send-mail-hook) + ;; Pass it on to mh. + (mh-send-letter))) (defun message-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 +1799,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 +1823,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 +1847,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 +1864,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" t))) + (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)) @@ -1784,8 +2150,16 @@ (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) + (kill-buffer (current-buffer))))) +(defun message-output (filename) + "Append this article to Unix/babyl mail file.." + (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 +2377,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 +2397,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 +2420,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 +2465,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 +2480,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 +2549,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 +2557,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 +2689,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 +2790,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 +2821,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. @@ -2456,7 +2841,7 @@ mct (message-fetch-field "mail-copies-to") reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) references (message-fetch-field "references") - message-id (message-fetch-field "message-id")) + message-id (message-fetch-field "message-id" t)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) @@ -2491,6 +2876,9 @@ (insert (prog1 (rmail-dont-reply-to (buffer-string)) (erase-buffer))) (goto-char (point-min)) + ;; Perhaps Mail-Copies-To: never removed the only address? + (when (eobp) + (insert (or reply-to from ""))) (setq ccalist (mapcar (lambda (addr) @@ -2501,9 +2889,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 +2914,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 @@ -2548,7 +2942,7 @@ date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") - message-id (message-fetch-field "message-id") + message-id (message-fetch-field "message-id" t) followup-to (message-fetch-field "followup-to") newsgroups (message-fetch-field "newsgroups") reply-to (message-fetch-field "reply-to") @@ -2558,9 +2952,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 +2968,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 +3002,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") @@ -2640,7 +3038,7 @@ (message-narrow-to-head) (setq from (message-fetch-field "from") newsgroups (message-fetch-field "newsgroups") - message-id (message-fetch-field "message-id") + message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal @@ -2659,7 +3057,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 +3115,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 +3130,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 +3145,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 +3164,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 +3198,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 +3315,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 +3330,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 +3360,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 +3401,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 +3415,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/messagexmas.el --- a/lisp/gnus/messagexmas.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/messagexmas.el Mon Aug 13 09:13:56 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 @@ -92,6 +92,13 @@ (fset 'message-exchange-point-and-mark 'message-xmas-exchange-point-and-mark) +(defun message-xmas-maybe-fontify () + (when (and (featurep 'font-lock) + font-lock-auto-fontify) + (turn-on-font-lock))) + +(add-hook 'message-mode-hook 'message-xmas-maybe-fontify) + (provide 'messagexmas) ;;; messagexmas.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/messcompat.el --- a/lisp/gnus/messcompat.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/messcompat.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnbabyl.el --- a/lisp/gnus/nnbabyl.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnbabyl.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nndb.el --- a/lisp/gnus/nndb.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nndb.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nndir.el --- a/lisp/gnus/nndir.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nndir.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nndoc.el --- a/lisp/gnus/nndoc.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nndoc.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nndraft.el --- a/lisp/gnus/nndraft.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nndraft.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nneething.el --- a/lisp/gnus/nneething.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nneething.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnfolder.el --- a/lisp/gnus/nnfolder.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnfolder.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nngateway.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nngateway.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnheader.el --- a/lisp/gnus/nnheader.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnheader.el Mon Aug 13 09:13:56 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) - (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 (gnus-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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnheaderxm.el --- a/lisp/gnus/nnheaderxm.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnheaderxm.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnkiboze.el --- a/lisp/gnus/nnkiboze.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnkiboze.el Mon Aug 13 09:13:56 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,139 @@ (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 + (when (file-exists-p nov-file) + (insert-file-contents nov-file)) + (setq nov-buffer (current-buffer)) + ;; Go through the active hashtb and add new all groups that match the + ;; kiboze regexp. + (mapatoms + (lambda (group) + (and (string-match nnkiboze-regexp + (setq gname (symbol-name group))) ; Match + (not (assoc gname nnkiboze-newsrc)) ; It isn't registered + (numberp (car (symbol-value group))) ; It is active + (or (> nnkiboze-level 7) + (and (setq glevel (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 +325,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnmail.el --- a/lisp/gnus/nnmail.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnmail.el Mon Aug 13 09:13:56 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,117 @@ ;; 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 + (when (file-exists-p tofile) + (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 + (when (file-exists-p tofile) + (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 +608,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 +693,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 +702,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 +821,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 +839,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 +856,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 +894,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 +906,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 +928,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 +937,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 +972,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 +985,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 +999,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 +1026,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 +1041,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 +1052,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 +1103,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 +1226,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 +1251,24 @@ (eq nnmail-spool-file 'procmail)) nil) ((listp nnmail-spool-file) - (append nnmail-spool-file procmails)) + (nconc + (apply + 'nconc + (mapcar + (lambda (file) + (if (and (not (string-match "^po:" file)) + (file-directory-p file)) + (nnheader-directory-regular-files file) + (list file))) + nnmail-spool-file)) + procmails)) ((stringp nnmail-spool-file) - (cons nnmail-spool-file procmails)) + (if (and (not (string-match "^po:" nnmail-spool-file)) + (file-directory-p nnmail-spool-file)) + (nconc + (nnheader-directory-regular-files nnmail-spool-file) + procmails) + (cons nnmail-spool-file procmails))) ((eq nnmail-spool-file 'pop) (cons (format "po:%s" (user-login-name)) procmails)) (t @@ -958,10 +1281,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 +1300,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 +1334,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 +1348,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 +1377,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 +1389,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 +1412,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 +1432,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 +1452,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 +1464,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 +1522,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnmbox.el --- a/lisp/gnus/nnmbox.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnmbox.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnmh.el --- a/lisp/gnus/nnmh.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnmh.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnml.el --- a/lisp/gnus/nnml.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnml.el Mon Aug 13 09:13:56 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,23 @@ (t (nnheader-report 'nnml "Article %s retrieved" id) ;; We return the article number. - (cons newsgroup (string-to-int (file-name-nondirectory path))))))) + (cons (if group-num (car group-num) 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 +216,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 +251,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 +265,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 @@ -313,7 +318,9 @@ (int-to-string article))) (file-error nil)) (nnml-nov-delete-article group article) - (and last (nnml-save-nov)))) + (when last + (nnml-save-nov) + (nnmail-save-active nnml-group-alist nnml-active-file)))) result)) (deffoo nnml-request-accept-article (group &optional server last) @@ -323,16 +330,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 +354,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 +372,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 +415,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 +510,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 +579,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 +591,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 +626,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 +666,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 +680,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 +700,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 +728,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 +749,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 +761,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 +770,23 @@ (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 (nnheader-find-nov-line article) + (delete-region (point) (progn (forward-line 1) (point))) + (when (bobp) + (let ((active (cadr (assoc group nnml-group-alist))) + num) + (when active + (if (eobp) + (setf (car active) (1+ (cdr active))) + (when (and (setq num (ignore-errors (read (current-buffer)))) + (numberp num)) + (setf (car active) num))))))) t)) (provide 'nnml) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnoo.el --- a/lisp/gnus/nnoo.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnoo.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnsoup.el --- a/lisp/gnus/nnsoup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnsoup.el Mon Aug 13 09:13:56 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) @@ -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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnspool.el --- a/lisp/gnus/nnspool.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnspool.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nntp.el --- a/lisp/gnus/nntp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nntp.el Mon Aug 13 09:13:56 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,564 @@ "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." +This function is supposed to be called from `nntp-server-opened-hook'." (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 +1124,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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnvirtual.el --- a/lisp/gnus/nnvirtual.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/nnvirtual.el Mon Aug 13 09:13:56 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,28 +176,51 @@ (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))))))) + +(defvoo nnvirtual-last-accessed-component-group nil) + (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))) - (cond - ((not amap) - (nnheader-report 'nnvirtual "No such article: %s" article)) - ((not (gnus-check-group cgroup)) - (nnheader-report - 'nnvirtual "Can't open server where %s exists" cgroup)) - ((not (gnus-request-group cgroup t)) - (nnheader-report 'nnvirtual "Can't open component group %s" cgroup)) - (t - (if buffer - (save-excursion - (set-buffer buffer) - (gnus-request-article-this-buffer (caddr amap) cgroup)) - (gnus-request-article (caddr amap) cgroup))))))) + (when (nnvirtual-possibly-change-server server) + (if (stringp article) + ;; This is a fetch by Message-ID. + (cond + ((not nnvirtual-last-accessed-component-group) + (nnheader-report + 'nnvirtual "Don't know what server to request from")) + (t + (save-excursion + (when buffer + (set-buffer buffer)) + (let ((method (gnus-find-method-for-group + nnvirtual-last-accessed-component-group))) + (funcall (gnus-get-function method 'request-article) + article nil (nth 1 method) buffer))))) + ;; This is a fetch by number. + (let* ((amap (nnvirtual-map-article article)) + (cgroup (car amap))) + (cond + ((not amap) + (nnheader-report 'nnvirtual "No such article: %s" article)) + ((not (gnus-check-group cgroup)) + (nnheader-report + 'nnvirtual "Can't open server where %s exists" cgroup)) + ((not (gnus-request-group cgroup t)) + (nnheader-report 'nnvirtual "Can't open component group %s" cgroup)) + (t + (setq nnvirtual-last-accessed-component-group cgroup) + (if buffer + (save-excursion + (set-buffer buffer) + (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 +229,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 +258,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 +356,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" (gnus-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" (gnus-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." + (when nnvirtual-current-group + (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) -(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)))))) + ;; 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)))) + + ;; 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/nnweb.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnweb.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/parse-time.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/parse-time.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/pop3.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pop3.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/score-mode.el --- a/lisp/gnus/score-mode.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/score-mode.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/gnus/smiley.el --- a/lisp/gnus/smiley.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/gnus/smiley.el Mon Aug 13 09:13:56 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 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/ANNOUNCEMENT --- a/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ Hello, -I've written a new version (5.0) of my html package for the XEmacs +I've written a new version (5.1) of my html package for the XEmacs and the GNU Emacs 19. The name of the package is: - hm--html-menus-5.0.tar.gz + hm--html-menus-5.1.tar.gz With this package it is very easy to write html pages for the World Wide Web (WWW). Eg: In most cases the user gets help to construct a specific @@ -12,17 +12,19 @@ source and destination (drag and drop feature). The biggest new features in this release are: -- drag and drop functions to insert links with the mouse -- a minor mode to extent other html modes like the psgml mode -- some new html tags, like the tags -- fixed some old html tags -- the pulldown menu in the Emacs 19 is no longer a global menu -- the popup menus in the Emacs 19 are now much fastere -- the name of the mode has changed from html-mode to hm--html-mode -- the package is longer based on the package of Marc Andreessen +- a better drag and drop interface to insert links with the mouse +- help feature for the drag and drop commands +- there's now also a default drag and drop table for other modes +- a better interface for inserting template files +- indentation +- better font lock stuff +- a site specific configuration file + (look at the variable hm--html-site-config-file) +- a better syntax table from Bob Weiner +- a lot of bug fixes Read the NEWS file to see news in detail... -You should find hm--html-menus-5.0.tar.gz on the following ftp server: +You should find hm--html-menus-5.1.tar.gz on the following ftp server: sunsite.unc.edu in /pub/Linux/apps/editors/emacs/ ftp.rrzn.uni-hannover.de in /pub/unix/editors/lemacs/contrib ftp.tnt.uni-hannover.de in /pub/editors/xemacs/contrib @@ -31,7 +33,11 @@ from the incoming directories to the above listed directories. There is also a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de:80/data/info/www/tnt/soft/info/www/html-editors/hm--html-menus/overview.html +http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html + +NOTE: This version is not tested with the Emacs 19. One of the next +releases in the near future will be a bug fix only release for the +Emacs 19. So please report any bugs to muenkel@tnt.uni-hannover.de. The package provides functions to insert the following stuff in html-pages: 1. Anchors: @@ -78,7 +84,9 @@ menu interactively. With the pulldown menu, you can do the following things: -- select the pulldown menu +- select the popup menu +- start a drag and drop command +- get help on a drag and drop command - remove numeric names - quotify hrefs - reload the config files @@ -113,7 +121,8 @@ The html specification is under development and therefore this package is also under development. So, if you have any ideas to -extend the package, feel free to email them to muenkel@tnt.uni-hannover.de. +extend the package, feel free to email them to +muenkel@tnt.uni-hannover.de. Heiko diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/NEWS --- a/lisp/hm--html-menus/NEWS Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/NEWS Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,96 @@ +12.02.97 + Renamed command-description.tmpl to command-description.html.tmpl. + The indentation stuff can now be disabled by setting the + variable `hm--html-disable-indentation' to t. + Fixed the long annoying bug, that the directory in the pop up + frame for selecting the template file was wrong in most cases. + -- BUILDED the version 5.1 of the package +11.02.97: + Changed the whole indentation stuff. It is now all working - + with the exceptions, that the list `hm--html-tag-name-alist' + contains not all "one element tags", and also text between + pre tags will be intended. +09.02.97: + Fixed a bug in the template stuff. + Moved the whole indentation stuff to the new file + hm--html-indentation.el. +06.02.97: + The indentation of two tag elements are now working. +03.02.97: + It is now possible to use an own site specific configuration file. + For that the variable `hm--html-site-config-file' was added. + Added some code from Bob Weiner to modify the syntax table, + change the comment start and end and the sentence end. + Started to add the indentation. + The indentation in comments is now working. +01.02.97: + In the source and destination description of a drag and drop + are now used marks instead of points. This fixed bugs, which + occured, if the source and the destination buffer are the same. + A help feature was implemented. +30.01.97: + Added some new features to the drag and drop interface, like + the macro `idd-start-mouse-drag-and-drop', which is usefull to + define action functions. The event is now also stored in the source + and destination description. + Changed the order of the arguments destination and source + to source and destination. + Changed the name of all idd specification type functions + to idd-if-*-p. +27.01.97: + Changed the source and destination in the drag and drop functions, + so that they are now used in a standard way. + Added the command `idd-start-mouse-drag-and-drop', which could + be used to start a drag and drop command without a button-press-event. + Used the command `idd-start-mouse-drag-and-drop' in the hm--html + menus. +26.01.97: + Renamed the function `tmpl-insert-template-file' to + `tmpl-insert-template-file-from-fixed-dirs'. + Added a function `tmpl-insert-template-file', which doesn't use + a file filter and a list of directories. + Changed both functions, so that they now use the variables + `tmpl-template-dir-list', `tmpl-automatic-expand', + `tmpl-filter-regexp' and `tmpl-history-variable-name' + instead of optional arguments. + Changed the name of the file frame.html to frame.html.tmpl. This is + usefull, if you've templates for multiple modes in one directory and + you want to use the new filter feature of the command + `tmpl-insert-template-file-from-fixed-dirs'. + Changed the function `hm--html-insert-template' and added + the function `hm--html-insert-template-from-fixed-dirs'. They are + using the functions `tmpl-insert-template-file' and + `tmpl-insert-template-file-from-fixed-dirs'. + The function `hm--html-insert-created-comment' is no longer + called in this functions. If needed, then this function must be + inserted in the template file. This is done now with the file + frame.html.tmpl. +22.01.97: + Changed the function `tmpl-insert-template-file': + It is now possible to use a file filter and a list + of directories, in which template files could be. +19.01.97: + Applied a patch from Andreas Ernst to fix bugs in the table stuff. + Added a '(let ((case-fold-seach t))' in all functions of hm--html.el, + which are call a search function with lowercase letters. + The functions to insert ordered, normal and dired list are fixed to + use
    • tags instead of only
  • . + Fixed a keybind bug for C-c C-s i. + Fixed a wrong call to `hm--html-add-only-description-entry'. + Fixed a bug in the argument list of hm--html-add-tags-to-region. + Fixed a bug in `hm--html-add-tags-to-region', which was caused by the + indentation. + Fixed a bug in `hm--html-add-relative-link-to-region' and + `hm--html-add-relative-link'. + Replaced `hm--html-file-relative-name' with `file-relative-name'. + Changed the font-lock stuff. It uses now the property list of + `font-lock-defaults' and the three keyword lists + 'html-font-lock-keywords', `html-font-lock-keywords-1' and + `html-font-lock-keywords-2'. + Fixed a bug in the drag and drop variables. + Changed the drag and drop command, so that it could be called + also from a menu. + Added the drag and drop command to the pop up menus. 15.08.96: The items of the menu "Set popup menu" are now radio items. -- BUILDED the version 5.0 of the package diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/README --- a/lisp/hm--html-menus/README Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/README Mon Aug 13 09:13:56 2007 +0200 @@ -1,4 +1,4 @@ -This README file describes the emacs lisp package hm--html-menus-5.0. +This README file describes the emacs lisp package hm--html-menus-5.1. The package provides functions and various popup and pulldown menus for a html mode called hm--html-mode, a mode for writing html pages. @@ -9,11 +9,8 @@ interface, which makes it very easy to insert links or images, by just clicking on them. -Look at the file NEWS, to see what is new in this release. One of the -main changes is, that it is no longer based on the html-mode.el -package from Marc Andreessen. Therefore the name of the mode has -changed to hm--html-mode and also the way to install the package is a -little bit different. So please read the installtion hints CAREFULLY! +Look at the file NEWS, to see what is new in this release. Some +of the major changes are also listed in the ANNOUNCEMENT file. You should (but don't need) also get the w3 package from: @@ -23,17 +20,24 @@ and epoch. -This package is tested with the xemacs 19.14 and the emacs 19.30 on -Suns with SunOS 4.1.3 and 5.5 and on PC's with linux. But it should -work also on other (possibly only UNIX ?) platforms. +This package is tested with the xemacs 19.15 on Suns with SunOS 5.5 +and on PC's with linux. But it should work also on other (possibly +only UNIX ?) platforms. -Read the file README-EMACS-19, if you want to use this package with -GNU Emacs 19. +NOTE: The current release isn't tested with the Emacs 19 (5.0 is but +5.1 isn't). One of the next releases in the near future :-) will be a +bug fix only release for the Emacs 19. So please report any bugs to +muenkel@tnt.uni-hannover.de to shorten the time until the Emacs 19 +related bugs are fixed. + +Read the file README-EMACS-19, if you want to use this package with +GNU Emacs 19. Thanks to Richard Stallman, who has helped me to port this package to the Emacs 19 and thanks to John Ladwig, who has corrected a lot of the -text and comments in this package and to all the other people, who had -provided code, ideas, bug fixes or bug reports for this package. +text and comments in this package and to all the other people like +Jerry G. DeLapp, Andreas Ernst and so on, who had provided code, +ideas, bug fixes or bug reports for this package. The package consists of the following files: @@ -48,6 +52,7 @@ hm--html.el : provides functions to write html pages; some of these functions are similar to functions of the html-mode.el; +hm--html-indentation.el : provides the indentation stuff; hm--html-keys.el : provides the new keybindings; hm--html-menu.el : provides the menus; hm--html-mode.el : provides the functions for the definition @@ -57,6 +62,8 @@ choose this as system configuration file; hm--html-drag-and-drop.el : defines the HTML- specific functions for the drag and drop interface; +hm--html-indentation.el : defines functions for the indentation of + HTML elements; hm--date.el : defines the function hm--date, which returns the date in the format "day-month-year" like "30-Jun-1993". @@ -72,14 +79,15 @@ with this mode you can expand templates, which are described in the file templates-syntax.doc (look at the files - command-description.tmpl and frame.tmpl for - examples); + command-description.tmpl and + frame.html.tmpl for examples); templates can be expanded automatically, if you include a file with templates via the - html pulldown menu item "Templates ..."; -command-description.tmpl : Templatefile for the use with the + html pulldown menu item "Templates ..." + or with the item "Templates (fixed dirs)..."; +command-description.html.tmpl : Templatefile for the use with the tmpl-minor-mode; -frame.tmpl : Templatefile, provides a simple frame; +frame.html.tmpl : Templatefile, provides a simple frame; @@ -146,8 +154,8 @@ It could also be, that you've already the autoload lines for the w3 package in your emacs. -3. Set the environment variable HTML_CONFIG_FILE to the html system - configuration file i.e.: +3. Set (if you want) the environment variable HTML_CONFIG_FILE + to the html system configuration file i.e.: setenv HTML_CONFIG_FILE /usr/xemacs/lisp/hm--html-configuration.el 4. Set (if you want) the environment variable HTML_USER_CONFIG_FILE to @@ -158,11 +166,20 @@ 5. Check the files hm--html-configuration.el and .hm--html-configuration.el whether all variables are set suitable for - you and your site or not. You can make changes in both of these files. + you and your site or not. You can make changes in both of these files + and you can also create a site specific configuration file, called + hm--html-site-config-file.el and specified by the lisp variable + hm--html-site-config-file or the environment variable + HTML_SITE_CONFIG_FILE, and put your site specific settings in this + file. A site specific configuration file is useful, if you're a + system administrator and want to make site specific settings + without changing a file of this package or use the normal emacs + configuration files. Note that .hm--html-configuration.el precedes the settings in - hm--html-configuration.el, because it is the user specific - configuration file. So you should made site specific changes in - hm--html-configuration.el. + hm--html-site-config-file.el, which precedes the settings in + hm--html-configuration.el (user specific configuration overwrites + site specific configuration and site specific configuration + overwrites the settings made by the package). Look at first at the following variables: @@ -176,7 +193,7 @@ 6. If you want to use templatefiles, you should put these files in the directory to which `hm--html-template-dir' points. - You can use the file command-description.tmpl as + You can use the file command-description.html.tmpl as an example. 7. If you don't want to use the feature of adding html comments @@ -237,8 +254,9 @@ it should be, but at the moment I've not the time to make a better one. -There is also a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de:80/data/info/www/tnt/soft/info/www/html-editors/hm--html-menus/overview.html +There is also a (small) html documentation about the package. You can +find it on: +http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html Please send any bug reports, fixes or comments to diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/adapt.el --- a/lisp/hm--html-menus/adapt.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/adapt.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,4 +1,4 @@ -;;; $Id: adapt.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: adapt.el,v 1.2 1997/02/15 22:21:03 steve Exp $ ;;; ;;; Copyright (C) 1993, 1994, 1995 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -312,6 +312,10 @@ minor-mode-map-alist)))) )) ) + + (if (not (fboundp 'redraw-modeline)) + (defalias 'redraw-modeline 'force-mode-line-update)) + )) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/command-description.html.tmpl Binary file lisp/hm--html-menus/command-description.html.tmpl has changed diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/frame.html.tmpl Binary file lisp/hm--html-menus/frame.html.tmpl has changed diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-configuration.el --- a/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,8 +1,8 @@ ;;; hm--html-configuration.el - Configurationfile for the html-mode ;;; -;;; $Id: hm--html-configuration.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html-configuration.el,v 1.2 1997/02/15 22:21:03 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -49,6 +49,11 @@ \"HTML_USER_CONFIG_FILE\" is set. Example value: \"~/.hm--html-configuration.el\".") +;;; The site specific config file +(defvar hm--html-site-config-file nil + "*The location of a site specific config file. +This variable will only be used, if no environment variable +\"HTML_SITE_CONFIG_FILE\" is set.") ;;; Chose the initial popup menu (defvar hm--html-expert nil @@ -309,15 +314,25 @@ ;;; For the Templates (defvar hm--html-template-dir "/data/info/www/tnt/guide/templates" - "*A directory with templatefiles") + "*A directory with templatefiles. +It is now also possible to use it as a list of directories. +Look at the variable `tmpl-template-dir-list' for further descriptions.") -(if (not (file-exists-p hm--html-template-dir)) +(if (listp hm--html-template-dir) + (unless (file-exists-p (car hm--html-template-dir)) + ;; Use a system directory, if the above one doesn't exist + ;; This may only be useful, in the XEmacs >= 19.12 + (setq hm--html-template-dir (cons (concat data-directory + "../lisp/hm--html-menus/") + hm--html-template-dir))) + (unless (file-exists-p hm--html-template-dir) ;; Use a system directory, if the above one doesn't exist - ;; This is only useful, in the XEmacs 19.12 + ;; This may only be useful, in the XEmacs >= 19.12 (setq hm--html-template-dir (concat data-directory - "../lisp/hm--html-menus/"))) + "../lisp/hm--html-menus/")))) -(defvar hm--html-frame-template-file (concat hm--html-template-dir +(defvar hm--html-frame-template-file (concat data-directory + "../lisp/hm--html-menus/" "frame.tmpl") "File, which is used as template for a html frame.") @@ -326,6 +341,8 @@ tmpl-minor-mode.el from Heiko Muenkel (muenkel@tnt.uni-hannover.de), which is distributed with the package hm--html-menus.") +(defvar hm--html-template-filter-regexp ".*\\.html\\.tmpl$" + "*Regexp for filtering out non template files in a directory.") ;;; for deleting the automounter path-prefix (defvar hm--html-delete-wrong-path-prefix '("/tmp_mnt" "/phys/[^/]+") @@ -371,36 +388,50 @@ drag and drop.") (defvar hm--html-idd-actions - '((nil (((idd-major-mode-p . dired-mode) - (idd-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)")) + '((nil (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpg\\)")) hm--html-idd-add-include-image-from-dired-line) - (((idd-major-mode-p . dired-mode) - (idd-dired-no-file-on-line-p . nil)) + (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-no-file-on-line-p . nil)) hm--html-idd-add-file-link-to-file-on-dired-line) - (((idd-major-mode-p . dired-mode) - (idd-dired-no-file-on-line-p . t)) + (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-no-file-on-line-p . t)) hm--html-idd-add-file-link-to-directory-of-buffer) - (((idd-major-mode-p . w3-mode) - (idd-url-at-point-p . t)) + (((idd-if-major-mode-p . w3-mode) + (idd-if-url-at-point-p . t)) hm--html-idd-add-html-link-from-w3-buffer-point) - (((idd-major-mode-p . w3-mode)) + (((idd-if-major-mode-p . w3-mode)) hm--html-idd-add-html-link-to-w3-buffer) - (((idd-local-file-p . t)) + (((idd-if-local-file-p . t)) hm--html-idd-add-file-link-to-buffer))) - "The action list for the source mode `hm--html-mode'. + "The action list for the destination mode `hm--html-mode'. Look at the description of the variable idd-actions") ;;; The font lock keywords -(defvar hm--html-font-lock-keywords +(defconst hm--html-font-lock-keywords-1 (list - '("\\(\\)\\|\\(<[^>]*>\\)+" . font-lock-comment-face) - '("[Hh][Rr][Ee][Ff]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t) - '("[Ss][Rr][Cc]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) + '("" . font-lock-comment-face) + '("<[^>]*>" . font-lock-keyword-face) + '("<[^>=]*href[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) + '("<[^>=]src[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) + "Subdued level highlighting for hm--html-mode.") + +(defconst hm--html-font-lock-keywords-2 + (append hm--html-font-lock-keywords-1 + (list + '(">\\([^<]*\\)" 1 font-lock-reference-face) + '("\\([^<]*\\)" 1 bold) + '("\\([^<]*\\)" 1 italic) + )) + "Gaudy level highlighting for hm--html-mode.") + +(defvar hm--html-font-lock-keywords hm--html-font-lock-keywords-1 "Default expressions to highlight in the hm--html-mode.") + ;;; The Prefix- Key for the keytables (defvar hm--html-minor-mode-prefix-key "\C-z" "The prefix key for the keytables in the `hm--html-minor-mode'.") @@ -440,6 +471,34 @@ Linux : (setq html-sigusr1-signal-value 10))") +;;; indentation + +(defvar hm--html-disable-indentation nil + "*Set this to t, if you want to disable the indentation in the hm--html-mode. +And may be send me (muenkel@tnt.uni-hannover.de) a note, why you've +done this.") + +(defvar hm--html-inter-tag-indent 2 + "*The indentation after a start tag.") + +(defvar hm--html-comment-indent 5 + "*The indentation of a comment.") + +(defvar hm--html-intra-tag-indent 2 + "*The indentation after the start of a tag.") + +(defvar hm--html-tag-name-alist + '(("!--" (:hm--html-one-element-tag t)) + ) + "An alist with tag names known by the `hm--html-mode'. +CURRENTLY THIS LIST CONTAINS NOT ALL TAGS!!!!. + +It is used to determine, if a tag is a one element tag or not. + +In the future it should also be used to get possible parameters of +the tag.") + + ;;; Announce the feature hm--html-configuration (provide 'hm--html-configuration) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-drag-and-drop.el --- a/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: hm--html-drag-and-drop.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html-drag-and-drop.el,v 1.2 1997/02/15 22:21:03 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -35,133 +35,133 @@ (require 'internal-drag-and-drop) (require 'cl) -(defun hm--html-first-non-matching-position (string1 string2) - "Compares both strings and returns the first position, which is not equal." - (let ((n 0) - (max-n (min (length string1) (length string2))) - (continue t)) - (while (and continue (< n max-n)) - (when (setq continue (= (aref string1 n) (aref string2 n))) - (setq n (1+ n)))) - n)) +;(defun hm--html-first-non-matching-position (string1 string2) +; "Compares both strings and returns the first position, which is not equal." +; (let ((n 0) +; (max-n (min (length string1) (length string2))) +; (continue t)) +; (while (and continue (< n max-n)) +; (when (setq continue (= (aref string1 n) (aref string2 n))) +; (setq n (1+ n)))) +; n)) -(defun hm--html-count-subdirs (directory) - "Returns the number of subdirectories of DIRECTORY." - (let ((n 0) - (max-n (1- (length directory))) - (count 0)) - (while (< n max-n) - (when (= ?/ (aref directory n)) - (setq count (1+ count))) - (setq n (1+ n))) - (when (and (not (= 0 (length directory))) - (not (= ?/ (aref directory 0)))) - (setq count (1+ count))) - count)) +;(defun hm--html-count-subdirs (directory) +; "Returns the number of subdirectories of DIRECTORY." +; (let ((n 0) +; (max-n (1- (length directory))) +; (count 0)) +; (while (< n max-n) +; (when (= ?/ (aref directory n)) +; (setq count (1+ count))) +; (setq n (1+ n))) +; (when (and (not (= 0 (length directory))) +; (not (= ?/ (aref directory 0)))) +; (setq count (1+ count))) +; count)) -(defun hm--html-return-n-backwards (n) - "Returns a string with N ../" - (cond ((= n 0) "") - (t (concat "../" (hm--html-return-n-backwards (1- n)))))) +;(defun hm--html-return-n-backwards (n) +; "Returns a string with N ../" +; (cond ((= n 0) "") +; (t (concat "../" (hm--html-return-n-backwards (1- n)))))) -(defun* hm--html-file-relative-name (file-name - &optional (directory default-directory)) - "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." - (let* ((pos (hm--html-first-non-matching-position file-name directory)) - (backwards (hm--html-count-subdirs (substring directory pos))) - (relative-name (concat (hm--html-return-n-backwards backwards) - (substring file-name pos)))) - (if (= 0 (length relative-name)) - "./" - (if (= ?/ (aref relative-name 0)) - (if (= 1 (length relative-name)) - "./" - (substring relative-name 1)) - relative-name)))) +;(defun* hm--html-file-relative-name (file-name +; &optional (directory default-directory)) +; "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." +; (let* ((pos (hm--html-first-non-matching-position file-name directory)) +; (backwards (hm--html-count-subdirs (substring directory pos))) +; (relative-name (concat (hm--html-return-n-backwards backwards) +; (substring file-name pos)))) +; (if (= 0 (length relative-name)) +; "./" +; (if (= ?/ (aref relative-name 0)) +; (if (= 1 (length relative-name)) +; "./" +; (substring relative-name 1)) +; relative-name)))) (defun hm--html-idd-add-include-image-from-dired-line (source destination) - "Inserts an include image tag at the SOURCE. + "Inserts an include image tag at the DESTINATION. The name of the image is on a line in a dired buffer. It is specified by the -destination." - (idd-set-point source) +SOURCE." + (idd-set-point destination) (if hm--html-idd-create-relative-links - (hm--html-add-image-top (hm--html-file-relative-name - (idd-get-dired-filename-from-line destination)) + (hm--html-add-image-top (file-relative-name + (idd-get-dired-filename-from-line source)) (file-name-nondirectory - (idd-get-dired-filename-from-line destination))) - (hm--html-add-image-top (idd-get-dired-filename-from-line destination) + (idd-get-dired-filename-from-line source))) + (hm--html-add-image-top (idd-get-dired-filename-from-line source) (file-name-nondirectory - (idd-get-dired-filename-from-line destination))))) + (idd-get-dired-filename-from-line source))))) -(defun hm--html-idd-add-link-to-region (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE. +(defun hm--html-idd-add-link-to-region (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION. It uses the region as the name of the link." - (idd-set-region source) + (idd-set-region destination) (hm--html-add-normal-link-to-region link-object) ) -(defun hm--html-idd-add-link (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE." - (idd-set-point source) +(defun hm--html-idd-add-link (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION." + (idd-set-point destination) (hm--html-add-normal-link link-object)) -(defun hm--html-idd-add-link-to-point-or-region (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE. +(defun hm--html-idd-add-link-to-point-or-region (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION. It uses the region as the name of the link, if the region was active -in the SOURCE." - (if (cdr (assoc ':region-active source)) - (hm--html-idd-add-link-to-region link-object source) - (hm--html-idd-add-link link-object source))) +in the DESTINATION." + (if (cdr (assoc ':region-active destination)) + (hm--html-idd-add-link-to-region link-object destination) + (hm--html-idd-add-link link-object destination))) (defun hm--html-idd-add-file-link-to-file-on-dired-line (source destination) - "Inserts a file link in SOURCE to the file on the dired line of DESTINATION." - (idd-set-point source) + "Inserts a file link in DESTINATION to the file on the dired line of SOURCE." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name - (idd-get-dired-filename-from-line destination)) - source) + (file-relative-name + (idd-get-dired-filename-from-line source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-dired-filename-from-line destination)) - source))) + (concat "file://" (idd-get-dired-filename-from-line source)) + destination))) (defun hm--html-idd-add-file-link-to-buffer (source destination) - "Inserts a file link at SOURCE to the file of DESTINATION." - (idd-set-point source) + "Inserts a file link at DESTINATION to the file of the SOURCE buffer." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name (idd-get-local-filename destination)) - source) + (file-relative-name (idd-get-local-filename source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-local-filename destination)) - source))) + (concat "file://" (idd-get-local-filename source)) + destination))) (defun hm--html-idd-add-file-link-to-directory-of-buffer (source destination) - "Inserts a file link at SOURCE to the directory of the DESTINATION buffer." - (idd-set-point source) + "Inserts a file link at DESTINATION to the directory of the SOURCE buffer." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name (idd-get-directory-of-buffer destination)) - source) + (file-relative-name (idd-get-directory-of-buffer source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-directory-of-buffer destination)) - source))) + (concat "file://" (idd-get-directory-of-buffer source)) + destination))) (defun hm--html-idd-add-html-link-to-w3-buffer (source destination) - "Inserts a link at SOURCE to the w3 buffer specified by the DESTINATION. + "Inserts a link at DESTINATION to the w3 buffer specified by the SOURCE. Note: Relative links are currently not supported for this function." - (idd-set-point source) - (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url destination) - source)) + (idd-set-point destination) + (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url source) + destination)) (defun hm--html-idd-add-html-link-from-w3-buffer-point (source destination) - "Inserts a link at SOURCE to a lin in the w3 buffer. -The link in the w3-buffer is specified by the DESTINATION. + "Inserts a link at DESTINATION to a lin in the w3 buffer. +The link in the w3-buffer is specified by the SOURCE. Note: Relative links are currently not supported for this function." - (idd-set-point source) - (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point destination) - source)) + (idd-set-point destination) + (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point source) + destination)) ;;; Announce the feature hm--html-drag-and-drop (provide 'hm--html-drag-and-drop) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-indentation.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hm--html-menus/hm--html-indentation.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,251 @@ +;;; hm--html-indentation.el +;;; v1.00; 9-Feb-1997 +;;; Copyright (C) 1997 Heiko Muenkel +;;; email: muenkel@tnt.uni-hannover.de +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; +;;; Description: +;;; +;;; Defines functions for the indentation. +;;; +;;; Installation: +;;; +;;; Put this file in one of your load path directories. +;;; + +(defun hm--html-point-between-strings-p (string-1 + string-2 + &optional boundary) + "Returns non nil, if the current point is between STRING-1 and STRING-2." + (when (and (re-search-backward (concat "\\(" + (regexp-quote string-1) + "\\)\\|\\(" + (regexp-quote string-2) + "\\)") + boundary + t) + (match-string 1)) + (point))) + +(defun hm--html-in-comment-p () + "Checks if the current point is in a comment block. +If this is the case, then the start point of the comment is returned. +Otherwise nil is returned." + (save-excursion + (hm--html-point-between-strings-p comment-start comment-end))) + +(defun hm--html-previous-line-start () + "Returns the start of the previous non blank line." + (save-excursion + (beginning-of-line) + (skip-chars-backward " \t\n") + (beginning-of-line) + (point))) + +(defun hm--html-look-at-comment-end-p () + "T, if the current line starts with the comment end." + (looking-at (regexp-quote comment-end))) + +(defun hm--html-column-of-previous-regexp (regexp) + "Returns the column of the start of the previous REGEXP. +It searches backward until the REGEXP is found. If no +REGEXP is found, then it returns 0." + (save-excursion + (if (re-search-backward regexp nil t) + (current-column) + 0))) + +(defun hm--html-look-at-end-tag-p () + "Returns the end tag name if the point is at the start of an end tag. +nil is returned otherwise." + (when (looking-at "\\(<[ \t\n]*/[ \t\n]*\\)\\([^ \t\n>]+\\)") + (match-string 2))) + + +(defun hm--html-previous-line-indentation () + "Returns the indentation of the previous non blank line." + (save-excursion + (beginning-of-line) + (skip-chars-backward " \t\n") + (back-to-indentation) + (current-column))) + +(defun hm--html-in-tag-p () + "Checks if the current point is in a tag. +If this is the case, then the start point of the tag is returned. +Otherwise nil is returned." + (save-excursion + (let ((start (re-search-backward "\\(<\\)\\|\\(>\\)" nil t))) + (when (match-string 1) + start)))) + +(defun hm--html-return-beginning-of-line () + "Returns the beginning of the current line." + (save-excursion + (beginning-of-line) + (point))) + +(defun hm--html-return-end-of-line () + "Returns the end of the current line." + (save-excursion + (end-of-line) + (point))) + +(defun hm--html-paramter-column-in-line-after-point (point) + "Returns the column where the second non blank text after POINT starts. +This point must be in the line with POINT otherwise it returns nil." + (save-excursion + (goto-char point) + (when (re-search-forward "<[ \t]*[^ \t]+[ \t]" + (hm--html-return-end-of-line) + t) + (when (looking-at "[^\n]") + (current-column))))) + +(defun hm--html-column-of-point (point) + "Returns the column of the POINT." + (save-excursion + (goto-char point) + (current-column))) + +(defun hm--html-search-previous-tag-in-current-line () + "Searches tags from the `(point)' to the beginning of the line. +It returns nil, if there is no tag and the tag name, if there is +a tag. The tag name contains a leading /, if it is an end tag." + (when (re-search-backward ">" (hm--html-return-beginning-of-line) t) + (when (re-search-backward + "\\(<[ \t\n]*\\(/?\\)\\([ \t\n]*[^> \t\n]+\\)[^>]*\\)" + nil + t) + (concat (match-string 2) (match-string 3))))) + +(defun hm--html-search-start-tag (tag-name until) + "Searches start tag backwards from the current point until the point UNTIL. +The name of the tag is TAG-NAME. After this function the point is at UNTIL + (then it returns nil) or at the start of the tag, then it returns t." + (if (re-search-backward (concat "\\(<[ \t\n]*\\)\\(/?\\)\\(" + tag-name + "\\)\\([^>]*>\\)") until t) + (if (string= "/" (match-string 2)) + (progn + (hm--html-search-start-tag tag-name until) + (hm--html-search-start-tag tag-name until)) + t) + (goto-char until) + nil)) + +(defun hm--html-is-one-element-tag-p (tag-name) + "Returns t, if the tag with the tag-name is a one element tag." + (assoc :hm--html-one-element-tag + (cdr (assoc* tag-name hm--html-tag-name-alist :test 'string=)))) + +(defun hm--html-calculate-indent-according-to-previous-tags () + "Calculate the indent according to the previous tags in this line. +If no tags are found, then nil is returned." + (save-excursion + (let ((tag (hm--html-search-previous-tag-in-current-line))) + (cond ((not tag) nil) + + ((eq ?/ (elt tag 0)) ; end tag found + (if (hm--html-search-start-tag + (substring tag 1) + (point-min)) + (or (hm--html-calculate-indent-according-to-previous-tags) + (progn + (backward-to-indentation 0) + (current-column))) + 0)) ; it may be that the current indentation is better here + + ((hm--html-is-one-element-tag-p tag) ; one element tag + (or (hm--html-calculate-indent-according-to-previous-tags) + (progn + (backward-to-indentation 0) + (current-column)))) + + (t ; start tag found + (+ (current-column) hm--html-inter-tag-indent)))))) + + +(defun hm--html-calculate-indent () + "Calculate the indentation of the current line." + (let ((match-point) + (tag)) + (save-excursion + (beginning-of-line) + (back-to-indentation) + (cond ((eq (count-lines (point-min) (point)) 0) 0) ; Filestart + + ((setq match-point (hm--html-in-comment-p)) ; in a comment + (if (>= match-point (hm--html-previous-line-start)) ; 1. line + (if (hm--html-look-at-comment-end-p) + (hm--html-column-of-previous-regexp + (regexp-quote comment-start)) + (+ (hm--html-column-of-previous-regexp + (regexp-quote comment-start)) + hm--html-comment-indent)) + (if (hm--html-look-at-comment-end-p) + (- (hm--html-previous-line-indentation) + hm--html-comment-indent) + (hm--html-previous-line-indentation)))) + + ((setq tag (hm--html-look-at-end-tag-p)) ; look at end tag + (hm--html-search-start-tag tag (point-min)) + (current-column)) + + ((looking-at ">") + (hm--html-column-of-previous-regexp "<")) + + ((setq match-point (hm--html-in-tag-p)) + (if (>= match-point (hm--html-previous-line-start)) ; 1. line + (or (hm--html-paramter-column-in-line-after-point match-point) + (+ (hm--html-column-of-point match-point) + hm--html-intra-tag-indent)) + (hm--html-previous-line-indentation))) + + (t (or (save-excursion ; check previous line + (skip-chars-backward " \t\n") + (hm--html-calculate-indent-according-to-previous-tags)) + (hm--html-previous-line-indentation))) + )))) + +(defun hm--html-indent-line () + "Indent the current line line." + (interactive) + (unless hm--html-disable-indentation + (indent-line-to (max 0 (hm--html-calculate-indent))))) + +;;; Indentation + +(defun hm--html-indent-region (begin end) + "Indents the region between BEGIN and END according to the major mode." + (interactive "d\nm") + (when (< end begin) + (let ((a end)) + (setq end begin) + (setq begin a))) + (save-excursion + (goto-char begin) + (let ((old-point)) + (while (and (<= (point) end) + (not (eq (point) old-point))) + (setq old-point (point)) + (indent-according-to-mode) + (forward-line) + )))) + + +(provide 'hm--html-indentation) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-keys.el --- a/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,11 +1,11 @@ -;;; $Id: hm--html-keys.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html-keys.el,v 1.2 1997/02/15 22:21:04 steve Exp $ ;;; -;;; Copyright (C) 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1995, 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) +;;; 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, @@ -27,7 +27,6 @@ ;;; Put this file in one of your load path directories. ;;; -;; This is necessary to get the definition of hm--html-mode-prefix-key. (require 'hm--html-configuration) (if (adapt-emacs19p) @@ -192,7 +191,7 @@ (if hm--html-region-structure-map () (setq hm--html-region-structure-map (make-sparse-keymap)) - (define-key hm--html-noregion-structure-map + (define-key hm--html-region-structure-map "i" 'hm--html-add-list-or-menu-item-to-region) (define-key hm--html-region-structure-map "m" 'hm--html-add-menu-to-region) (define-key hm--html-region-structure-map "u" 'hm--html-add-list-to-region) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-menu.el --- a/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,8 +1,8 @@ ;;; hm--html-menu --- A menu for the hm--html-mode. ;;; -;;; $Id: hm--html-menu.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html-menu.el,v 1.2 1997/02/15 22:21:04 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -60,6 +60,10 @@ ("Anchors" ["Relative link..." hm--html-add-relative-link t] ["General link..." hm--html-add-normal-link t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link t] ["Info link..." hm--html-add-info-link t] @@ -206,6 +210,10 @@ ["Top aligned image..." hm--html-add-image-top t] ["Middle aligned image..." hm--html-add-image-middle t] ["Bottom aligned image..." hm--html-add-image-bottom t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Applet..." hm--html-add-applet t] ["Parameter..." hm--html-add-applet-parameter t] @@ -248,6 +256,10 @@ '("HTML No-region Novice Menu" ("Anchors" ["Relative link..." hm--html-add-relative-link t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link t] ["File link..." hm--html-add-file-link t] @@ -280,6 +292,10 @@ ("Anchors" ["Relative link..." hm--html-add-relative-link-to-region t] ["General link..." hm--html-add-normal-link-to-region t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link-to-region t] ["Info link..." hm--html-add-info-link-to-region t] @@ -411,6 +427,10 @@ '("HTML Region Novice Menu" ("Anchors" ["Relative link..." hm--html-add-relative-link-to-region t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link-to-region t] ["File link..." hm--html-add-file-link-to-region t] @@ -454,7 +474,18 @@ ; ["Marcs menu" hm--html-use-marcs-menu t] ) ["Reload config files" hm--html-load-config-files t] + ["Templates (fixed dirs) ..." + hm--html-insert-template-from-fixed-dirs + t] ["Templates ..." hm--html-insert-template t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] + ["Drag & Drop Help" + idd-start-help-mouse-drag-and-drop + :active t + :keys "\\[idd-help-mouse-drag-and-drop]"] "----" ["Remove numeric names" hm--html-remove-numeric-names t] ["Quotify hrefs" hm--html-quotify-hrefs t] diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html-mode.el --- a/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 09:13:56 2007 +0200 @@ -2,14 +2,14 @@ ;;; ;;; Keywords: hypermedia languages help docs wp ;;; -;;; $Id: hm--html-mode.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html-mode.el,v 1.2 1997/02/15 22:21:04 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) +;;; 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, @@ -64,6 +64,7 @@ (require 'hm--date) (require 'hm--html) (hm--html-load-config-files) +(require 'hm--html-indentation) (require 'hm--html-menu) (require 'hm--html-drag-and-drop) ;(hm--html-load-config-files) ; Load the system and user configuration files @@ -75,7 +76,7 @@ (defconst hm--html-menus-package-name "hm--html-menus") -(defconst hm--html-menus-package-version "5.0") +(defconst hm--html-menus-package-version "5.1") ;;; Generate the help buffer faces @@ -89,9 +90,15 @@ (if hm--html-mode-syntax-table () (setq hm--html-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) - (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) - (modify-syntax-entry ?' "w " hm--html-mode-syntax-table)) +; (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) +; (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) +; (modify-syntax-entry ?' "w " hm--html-mode-syntax-table) + (modify-syntax-entry ?\\ "." hm--html-mode-syntax-table) + (modify-syntax-entry ?' "w" hm--html-mode-syntax-table) + (modify-syntax-entry ?< "(>" hm--html-mode-syntax-table) + (modify-syntax-entry ?> ")<" hm--html-mode-syntax-table) + (modify-syntax-entry ?\" "\"" hm--html-mode-syntax-table) + (modify-syntax-entry ?= "." hm--html-mode-syntax-table)) ;;; abbreviation table @@ -119,12 +126,27 @@ (setq major-mode 'hm--html-mode) (setq local-abbrev-table hm--html-mode-abbrev-table) (set-syntax-table hm--html-mode-syntax-table) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (setq comment-start "") + (make-local-variable 'sentence-end) + (setq sentence-end "[<>.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") + (setq indent-line-function 'hm--html-indent-line) (setq idd-actions hm--html-idd-actions) (hm--install-html-menu hm--html-mode-pulldown-menu-name) (make-variable-buffer-local 'write-file-hooks) (add-hook 'write-file-hooks 'hm--html-maybe-new-date-and-changed-comment) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords hm--html-font-lock-keywords) +; (make-local-variable 'font-lock-keywords) +; (setq font-lock-keywords-case-fold-search t) +; (setq font-lock-keywords hm--html-font-lock-keywords) + (put major-mode 'font-lock-defaults '((hm--html-font-lock-keywords + hm--html-font-lock-keywords-1 + hm--html-font-lock-keywords-2) + t + t + nil + nil + )) (run-hooks 'hm--html-mode-hook)) ;;;; Minor Modes diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/hm--html.el --- a/lisp/hm--html-menus/hm--html.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/hm--html.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: hm--html.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: hm--html.el,v 1.2 1997/02/15 22:21:04 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -31,24 +31,14 @@ ;(require 'adapt) -;;; Indentation - -(defun hm--html-indent-region (begin end) - "Indents the region between BEGIN and END according to the major mode." - (when (< end begin) - (let ((a end)) - (setq end start) - (setq start a))) - (save-excursion - (goto-char begin) - (let ((old-point)) - (while (and (<= (point) end) - (not (eq (point) old-point))) - (setq old-point (point)) - (indent-according-to-mode) - (forward-line) - )))) - +(defun hm--html-set-marker-at-position (&optional position) + "Creates a new marker and set the marker at the POSITION. +If POSITION is nil, then the marker is set at the current point. +The return value is the marker." + (let ((marker (make-marker))) + (if position + (set-marker marker position) + (set-marker marker (point))))) ;;; Functions for adding html commands which consists of a start and a ;;; end tag and some text between them. (Basicfunctions) @@ -68,16 +58,12 @@ The second parameter is the string for the start tag and the fourth parameter is the string for the end tag. The third and fourth parameters are optional. The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-start-tag) between the start and the end -tag." -; (interactive "aFunction, which adds the HTML start tag: \n\ -;aFunction, which adds the HTML end tag: \n\ -;sThe HTML start tag: \n\ -;sThe HTML end tag: ") +inserts the sixth parameter (the middle-start-tag) between the start and the +end tag." (eval (list function-insert-start-tag start-tag)) (if function-insert-middle-start-tag (eval (list function-insert-middle-start-tag middle-start-tag))) - (let ((position (point))) + (let ((position (hm--html-set-marker-at-position (point)))) (if function-insert-middle-end-tag (eval (list function-insert-middle-end-tag middle-end-tag))) (if function-insert-end-tag @@ -89,8 +75,9 @@ start-tag function-insert-end-tag end-tag - &optional function-insert-middle-tag - &optional middle-tag) + &optional + function-insert-middle-tag + middle-tag) "Adds the start and the end html tag to the active region. The first parameter specifies the funtion which insert the start tag and the third parameter specifies the function which insert the end tag. @@ -99,16 +86,13 @@ The fifth parameter is optional. If it exists, it specifies a function which inserts the sixth parameter (the middle-tag) between the start and the end tag." -; (interactive "aFunction, which adds the html start tag: \n\ -;aFunction, which adds the html end tag: \n\ -;sThe HTML start tag: \n\ -;sThe HTML end tag: ") (save-window-excursion - (let ((start (region-beginning)) + (let ((start (hm--html-set-marker-at-position (region-beginning))) (end (region-end))) (goto-char end) (eval (list function-insert-end-tag end-tag)) (goto-char start) +; (backward-char (+ (length end-tag) (- end start))) (eval (list function-insert-start-tag start-tag)) (if function-insert-middle-tag (eval (list function-insert-middle-tag middle-tag))) @@ -140,7 +124,6 @@ (insert tag) (hm--html-indent-region start (point)) ) -; (html-maybe-deemphasize-region start (- (point) 1))) (insert "\n")) @@ -151,7 +134,6 @@ (let ((start (point))) (insert tag) (hm--html-indent-region start (point)))) -; (html-maybe-deemphasize-region start (- (point) 1)))) @@ -1177,7 +1159,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-numberlist-to-region () "Adds the HTML tags for a numbered list to the region." @@ -1185,9 +1169,9 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "
      " 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-directory-list () @@ -1198,7 +1182,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-directorylist-to-region () "Adds the HTML tags for a directory list to the region." @@ -1206,9 +1192,9 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "" 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-list () @@ -1219,7 +1205,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-list-to-region () @@ -1228,20 +1216,20 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "
      " 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • ")) - - -(defun hm--html-add-menu () - "Adds the HTML tags for a menu." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) + + +;(defun hm--html-add-menu () +; "Adds the HTML tags for a menu." +; (interactive) +; (hm--html-add-tags 'hm--html-insert-start-tag-with-newline +; "" +; 'hm--html-insert-end-tag-with-newline +; "" +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-menu () @@ -1274,9 +1262,10 @@ Assumes we're at the end of a previous entry." (interactive) (hm--html-add-description-title) - (let ((position (point))) - (search-forward "") - (hm--html-add-only-description-entry) + (let ((position (point)) + (case-fold-search t)) + (search-forward "") + (hm--html-add-description-entry) (goto-char position))) @@ -1378,18 +1367,19 @@ "Searches for the old signature and deletes it, if the user want it" (save-excursion (goto-char (point-min)) - (if (search-forward (concat "
    " - "" nil t) - (point)))) - (if (yes-or-no-p "Delete the old signature (yes or no) ?") - (delete-region signature-start signature-end)))))) + (let ((case-fold-search t)) + (if (search-forward (concat "
    " + "" nil t) + (point)))) + (if (yes-or-no-p "Delete the old signature (yes or no) ?") + (delete-region signature-start signature-end))))))) (defun hm--html-set-point-for-signature () @@ -1398,17 +1388,18 @@ tries to use the point before the tag then the point before the tag and the the end of the file." (goto-char (point-max)) - (cond ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((> (current-column) 0) - (newline 2)) - (t))) + (let ((case-fold-search t)) + (cond ((search-backward "" nil t) + (end-of-line 0) + (if (> (current-column) 0) + (newline 2))) + ((search-backward "" nil t) + (end-of-line 0) + (if (> (current-column) 0) + (newline 2))) + ((> (current-column) 0) + (newline 2)) + (t)))) (defun hm--html-add-signature () @@ -1467,10 +1458,11 @@ the tag . If this tag exists, the point is set to the position after this tag or the beginning of the file otherwise." (goto-char (point-min)) - (cond ((search-forward-regexp "" nil t) (newline)) - ((search-forward-regexp "" nil t) (newline)) - ((search-forward-regexp "" nil t) (newline)) - (t))) + (let ((case-fold-search t)) + (cond ((search-forward-regexp "" nil t) (newline)) + ((search-forward-regexp "" nil t) (newline)) + ((search-forward-regexp "" nil t) (newline)) + (t)))) (defun hm--html-add-title (title) @@ -1478,32 +1470,34 @@ (interactive "sTitle: ") (save-excursion (goto-char (point-min)) - (if (search-forward "" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (let ((start (point))) - (insert title " (" (hm--date) ")") - (goto-char start)))) - ;; Noch kein im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "" - 'insert - (concat title " (" (hm--date) ")")) - (forward-char 8) - (newline 1) - ))) + (let ((case-fold-search t)) + (if (search-forward "" nil t) + (let ((point-after-start-tag (point))) + (if (not (search-forward "" nil t)) + nil + (goto-char (- (point) 8)) + (delete-backward-char (- (point) point-after-start-tag)) + (let ((start (point))) + (insert title " (" (hm--date) ")") + (goto-char start)))) + ;; Noch kein im Buffer vorhanden + (hm--html-set-point-for-title) + (hm--html-add-tags 'hm--html-insert-start-tag + "<TITLE>" + 'hm--html-insert-end-tag + "" + 'insert + (concat title " (" (hm--date) ")")) + (forward-char 8) + (newline 1) + )))) (defun hm--html-add-title-to-region () "Adds the HTML tags for a title to the region." (interactive) - (let ((title (buffer-substring (region-beginning) (region-end)))) + (let ((title (buffer-substring (region-beginning) (region-end))) + (case-fold-search t)) (save-excursion (goto-char (point-min)) (if (search-forward "" nil t) @@ -1531,7 +1525,8 @@ The tag <HTML> will be inserted at the beginning and </HTML> at the end of the file." (interactive) - (let ((new-cursor-position nil)) + (let ((new-cursor-position nil) + (case-fold-search t)) (save-excursion (goto-char (point-min)) (if (search-forward "<html>" nil t) @@ -1553,6 +1548,7 @@ The tags will be inserted after <HTML> or at the beginning of the file. The function also looks for the tags <BODY> and ." (interactive) + (let ((case-fold-search t)) (goto-char (point-min)) (if (search-forward "" nil t) (if (search-forward "" nil t) @@ -1586,7 +1582,7 @@ (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "" 'hm--html-insert-end-tag-with-newline - ""))))) + "")))))) (defun hm--html-add-head-to-region () @@ -1602,6 +1598,7 @@ "Adds the HTML tags and in the buffer. The tags will be inserted before or at the end of the file." (interactive) + (let ((case-fold-search t)) (goto-char (point-max)) (if (search-backward "" nil t) (progn @@ -1626,7 +1623,7 @@ (if (not (= (current-column) 0)) (newline)) (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "" - 'hm--html-insert-end-tag-with-newline "")))) + 'hm--html-insert-end-tag-with-newline ""))))) (defun hm--html-add-body-to-region () @@ -1644,21 +1641,22 @@ ; (if (> size 6) ; (message "The size must be a number from 1 to 6 !") (interactive "sTitle and Header String: ") - (hm--html-add-title title) - (save-excursion - (goto-char (point-min)) - (search-forward "" nil t) - (if (search-forward "" nil t) - (progn - (search-forward "" nil t) - (newline 1)) - (if (search-forward "" nil t) - (newline 1) - (if (string= (what-line) "Line 1") - (progn - (end-of-line) - (newline 1))))) - (hm--html-add-header 1 title))) + (let ((case-fold-search t)) + (hm--html-add-title title) + (save-excursion + (goto-char (point-min)) + (search-forward "" nil t) + (if (search-forward "" nil t) + (progn + (search-forward "" nil t) + (newline 1)) + (if (search-forward "" nil t) + (newline 1) + (if (string= (what-line) "Line 1") + (progn + (end-of-line) + (newline 1))))) + (hm--html-add-header 1 title)))) (defun hm--html-add-title-and-header-to-region () @@ -1679,17 +1677,18 @@ header and the signature. The parameter TITLE specifies the title and the header of the document." (interactive "sTitle and Header String: ") - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-title-and-header title) - (if hm--html-signature-file - (hm--html-add-signature)) - (goto-char (point-min)) - (search-forward "" nil t) - (forward-line 1) - (if hm--html-automatic-created-comment - (hm--html-insert-created-comment))) + (let ((case-fold-search t)) + (hm--html-add-html) + (hm--html-add-head) + (hm--html-add-body) + (hm--html-add-title-and-header title) + (if hm--html-signature-file + (hm--html-add-signature)) + (goto-char (point-min)) + (search-forward "" nil t) + (forward-line 1) + (if hm--html-automatic-created-comment + (hm--html-insert-created-comment)))) (defun hm--html-add-full-html-frame-with-region () @@ -1734,14 +1733,15 @@ (defun hm--html-mark-example (parameter-list) "Marks the example of the parameterlist in the current buffer. It returns the example extent." - (if (hm--html-get-example-from-parameter-list parameter-list) - (progn - (search-forward (hm--html-get-example-from-parameter-list - parameter-list)) - (let ((extent (make-extent (match-beginning 0) - (match-end 0)))) - (set-extent-face extent 'hm--html-help-face) - extent)))) + (let ((case-fold-search t)) + (if (hm--html-get-example-from-parameter-list parameter-list) + (progn + (search-forward (hm--html-get-example-from-parameter-list + parameter-list)) + (let ((extent (make-extent (match-beginning 0) + (match-end 0)))) + (set-extent-face extent 'hm--html-help-face) + extent))))) (defun hm--html-unmark-example (extent) @@ -2420,7 +2420,8 @@ (file-exists-p proggate-allowed-file)) (save-window-excursion (let ((alist nil) - (buffername (find-file-noselect proggate-allowed-file))) + (buffername (find-file-noselect proggate-allowed-file)) + (case-fold-search t)) (set-buffer buffername) (toggle-read-only) (goto-char (point-min)) @@ -2575,7 +2576,8 @@ '(("")) (save-window-excursion (let ((alist nil) - (buffername (find-file-noselect newsrc-file))) + (buffername (find-file-noselect newsrc-file)) + (case-fold-search t)) (set-buffer buffername) (toggle-read-only) (goto-char (point-min)) @@ -2730,11 +2732,14 @@ (defun hm--html-add-relative-link (relative-file-path) "Adds the HTML tags for a relative link at the current point." - (interactive (list (read-file-name "Relative Filename: " - nil - nil - nil - ""))) + (interactive (list (file-relative-name + (read-file-name "Relative Filename: " + nil + nil + nil + "") + default-directory) + )) (hm--html-add-tags 'hm--html-insert-start-tag (concat ""))) + (concat "" + (mapconcat '(lambda (entry) + (concat "") + " "))) (defun hm--html-add-first-table-row (no-of-cells) @@ -3494,17 +3549,18 @@ (error "ERROR: There must be at least one cell in a row!")) (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat "" (if (<= no-of-cells 1) - "" + "" (concat (mapconcat '(lambda (entry) (concat ""))))) + " ") + " "))))) (defun hm--html-table-get-previous-alignments () @@ -3513,12 +3569,15 @@ An example for the return list: '(\"left\" \"default\" \"center\" \"right\")" (save-excursion (let* ((point-of-view (point)) - (end-of-last-row (search-backward "" nil t)) - (begin-of-last-row (progn (search-backward "" (point-min) t)) + (begin-of-last-row (progn (search-backward " (point) begin-of-last-row) @@ -3550,13 +3609,13 @@ (no-of-cells (length old-alignment-list))) (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat "" (if (<= no-of-cells 1) - "" + "" (concat (mapconcat '(lambda (entry) (concat "")))))) + " ") + " ")))))) (defun hm--html-add-row-entry (alignment) @@ -3632,34 +3691,36 @@ "Adds a colspawn attribute to a table cell. A prefix arg is used as no of COLUMNS." (interactive "NNo of columns, spaned by this cell: ") - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+colspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" columns))) - (insert (format " colspan=\"%d\"" columns))) - (error "ERROR: Point not in a table cell!")))) + (let ((case-fold-search t)) + (save-excursion + (if (and (search-backward "<" nil t) + (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) + (if (search-forward-regexp "\\([ \t\n]+colspan=\\)\\([^ \t\n>]*\\)" + nil + t) + (progn + (delete-region (match-beginning 2) (match-end 2)) + (insert (format "\"%d\"" columns))) + (insert (format " colspan=\"%d\"" columns))) + (error "ERROR: Point not in a table cell!"))))) (defun hm--html-table-add-rowspan-attribute (rows) "Adds a rowspan attribute to a table cell. A prefix arg is used as no of ROWS." (interactive "NNo of rows, spaned by this cell: ") - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+rowspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" rows))) - (insert (format " rowspan=\"%d\"" rows))) - (error "ERROR: Point not in a table cell!")))) + (let ((case-fold-search t)) + (save-excursion + (if (and (search-backward "<" nil t) + (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) + (if (search-forward-regexp "\\([ \t\n]+rowspan=\\)\\([^ \t\n>]*\\)" + nil + t) + (progn + (delete-region (match-beginning 2) (match-end 2)) + (insert (format "\"%d\"" rows))) + (insert (format " rowspan=\"%d\"" rows))) + (error "ERROR: Point not in a table cell!"))))) ;;; ISO-Characters for Emacs HTML-mode (Berthold Crysmann) @@ -4171,6 +4232,7 @@ 'hm--html-template-dir 'hm--html-url-alist 'hm--html-user-config-file + 'hm--html-site-config-file 'hm--html-username 'hm--html-wais-hostname:port-alist 'hm--html-wais-hostname:port-default @@ -4243,8 +4305,11 @@ (defun hm--html-load-config-files () "Load the html configuration files. First, the system config file (detemined by the environment variable -HTML_CONFIG_FILE; normaly hm--html-configuration.el(c)) is loaded and -after that the user config file (determined by the environment variable +HTML_CONFIG_FILE; normaly hm--html-configuration.el(c)) is loaded. +At second a site config file is loaded, if the environment variable +HTML_SITE_CONFIG_FILE or the lisp variable `hm--html-site-config-file' +is set to such a file. +At least the user config file (determined by the environment variable HTML_USER_CONFIG_FILE; normaly the file ~/.hm--html-configuration.el(c)). If no HTML_CONFIG_FILE exists, then the file hm--html-configuration.el(c) is searched in one of the lisp load path directories. @@ -4259,6 +4324,17 @@ (getenv "HTML_CONFIG_FILE")))) (load-library (expand-file-name (getenv "HTML_CONFIG_FILE"))) (load-library "hm--html-configuration")) + + ;; at second the site config file + (if (and (stringp (getenv "HTML_SITE_CONFIG_FILE")) + (file-exists-p + (expand-file-name + (getenv "HTML_SITE_CONFIG_FILE")))) + (load-file (expand-file-name (getenv "HTML_SITE_CONFIG_FILE"))) + (when (and (boundp 'hm--html-site-config-file) + (stringp hm--html-site-config-file) + (file-exists-p (expand-file-name hm--html-site-config-file))) + (load-file (expand-file-name hm--html-site-config-file)))) ;; and now the user config file (cond ((and (stringp (getenv "HTML_USER_CONFIG_FILE")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/internal-drag-and-drop.el --- a/lisp/hm--html-menus/internal-drag-and-drop.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/hm--html-menus/internal-drag-and-drop.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: internal-drag-and-drop.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ +;;; $Id: internal-drag-and-drop.el,v 1.2 1997/02/15 22:21:05 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -24,27 +24,28 @@ ;;; drag and drop actions in the emacs. One could start such an ;;; action by clicking with the mouse in the source buffer and ;;; then in the destination buffer. The action could depend on -;;; the points where youve clicked with the mouse, on the state +;;; the points where you've clicked with the mouse, on the state ;;; of the region, the point, the mark and any other properties ;;; of the source and the destination buffers. The actions are ;;; defined by the variable `idd-actions', which is a buffer local -;;; variable. The following is an example for the html-mode: -;;; (defvar html-idd-actions -;;; '((nil (((idd-major-mode-p . dired-mode) -;;; (idd-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)")) +;;; variable. The following is an example for the hm--html-mode: +;;; (defvar hm--html-idd-actions +;;; '((nil (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-file-on-line-p +;;; . ".*\\.\\(gif\\)\\|\\(jpq\\)")) ;;; hm--html-idd-add-include-image-from-dired-line) -;;; (((idd-major-mode-p . dired-mode) -;;; (idd-dired-no-file-on-line-p . nil)) +;;; (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-no-file-on-line-p . nil)) ;;; hm--html-idd-add-file-link-to-file-on-dired-line) -;;; (((idd-major-mode-p . dired-mode) -;;; (idd-dired-no-file-on-line-p . t)) +;;; (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-no-file-on-line-p . t)) ;;; hm--html-idd-add-file-link-to-directory-of-buffer) -;;; (((idd-major-mode-p . w3-mode) -;;; (idd-url-at-point-p . t)) +;;; (((idd-if-major-mode-p . w3-mode) +;;; (idd-if-url-at-point-p . t)) ;;; hm--html-idd-add-html-link-from-w3-buffer-point) -;;; (((idd-major-mode-p . w3-mode)) +;;; (((idd-if-major-mode-p . w3-mode)) ;;; hm--html-idd-add-html-link-to-w3-buffer) -;;; (((idd-local-file-p . t)) +;;; (((idd-if-local-file-p . t)) ;;; hm--html-idd-add-file-link-to-buffer))) ;;; Look at the variable `idd-actions' for further descriptions. ;;; @@ -60,45 +61,146 @@ ;;; At first you must click on the source and ;;; after that on the destination." ;;; t) -;;; (define-key global-map [(meta button1)] 'idd-mouse-drag-and-drop) ;;; ;;; Define actions in the variable `idd-actions'. ;;; +;;; The variable `idd-global-mouse-keys' defines the mouse keys, +;;; which are bound to the drag and drop command. +;;; +;;; The variable `idd-drag-and-drop-mouse-binding-type' determines +;;; if you've to hold a mouse button down during moving the mouse +;;; from the source to the destination or not. +;;; -(defvar idd-actions nil +(require 'adapt) +(require 'cl) + +(defvar idd-global-mouse-keys (if (adapt-emacs19p) + [(meta control mouse-1)] + [(meta control button1)]) + "The mouse keys for the command `idd-mouse-drag-and-drop'. +The command `idd-mouse-drag-and-drop' is bound during the loading +of the package internal-drag-and-drop to this keys in the global +key map. + +Set it to nil, if you don't want to bind this function during loading. + +If the command is already bound in the global keymap during loading, +then this key sequence will not be bind.") + +(defvar idd-global-help-mouse-keys (if (adapt-emacs19p) + [(meta control mouse-3)] + [(meta control button3)]) + "The mouse keys for the command `idd-help-mouse-drag-and-drop'. +The command `idd-mouse-drag-and-drop' is bound during the loading +of the package internal-drag-and-drop to this keys in the global +key map. + +Set it to nil, if you don't want to bind this function during loading. + +If the command is already bound in the global keymap during loading, +then this key sequence will not be bind.") + +(defvar idd-drag-and-drop-mouse-binding-type 'click + "*The type of the drag and drop mouse binding. +The value maybe `click or 'press-button-during-move. +A value of `click means, that you've to click over the source, leave +the button and click it again over the destination. +A value of 'press-button-during-move means, that you've to press +the button down over the source and hold it until the mouse pointer +is over the destination. + +The disadvantage of the `press-button-during-move' type compared with +the `click' type is, that you can't select a destination region and +therefore a drag and drop action depending on a selected region can't +be started with that type of mouse binding.") + +(defvar idd-actions '((((idd-if-region-active-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-copy-region)) + + (((idd-if-region-active-p . t)) + (((idd-if-region-active-p . t)) + idd-action-copy-replace-region)) + + (((idd-if-region-active-p . nil) + (idd-if-modifiers-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-move-region)) + + (((idd-if-region-active-p . t) + (idd-if-modifiers-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-move-replace-region)) + ) "The list with actions, depending on the source and the destination. The list looks like: - '(( ( ) - ( ) - : + '(( ( ) + ( ) + : ) - ( ( ) - ( ) - : + ( ( ) + ( ) + : ) : ) The looks like the following: '([( )]) -with :== idd-minor-mode-p | idd-buffer-name-p - | idd-region-active-p ... - -The looks like , except -that a valid is also idd-major-mode-p. +with :== idd-if-minor-mode-p | idd-if-buffer-name-p + | idd-if-region-active-p | idd-if-url-at-point-p + | idd-if-major-mode-p | idd-if-variable-non-nil-p + | idd-if-dired-file-on-line-p + | idd-if-dired-no-file-on-line-p + | idd-if-local-file-p | idd-if-buffer-name-p + | idd-if-modifiers-p | ... -If or is set to -nil, then every source or destination matches. `idd-actions' is a +The - functions must have two arguments, the first one +is the source or destination and the second is the . It must return +nil, if the test wasn't successfull and a number (in general 1), which +specifies the weight of the test function. The weights of all single tests +are added to a summary weight and assigned to the action. The action +with the highest weight is called from the action handler. Look at +the definition of `idd-if-major-mode-p', `idd-if-minor-mode-p' and so on for +examples. Look at the function `idd-get-source-or-destination-alist', if +you wan't to know the structure of the 'source-or-destination' argument +of these functions. + +The looks like , +but in general it could be set to nil in mode specific idd-action +lists. + +If or is set to +nil, then every source or source matches. `idd-actions' is a buffer local variable, which should be at least mode depended. So if -the is set to nil it says, that the source +the is set to nil it says, that the destination buffer must only have a specific mode. But however, it's also possible -to define a general `idd-actions' list, where the source mode is -specified by idd-major-mode-p. +to define a general `idd-actions' list, where the destination mode is +specified by `idd-if-major-mode-p'. - ist a function, which has two arguments, the specifies the -source and the second the destination.") + ist a function, which has two arguments, the first specifies the +source and the second the destination. Look at the function definition +of `idd-action-copy-region' and `idd-action-copy-replace-region'. They are +examples for such actions.") (make-variable-buffer-local 'idd-actions) +(defvar idd-help-instead-of-action nil + "*If this variable is t, then a help buffer is displayed. +No action will be performed if this variable is t.") + +(defvar idd-help-start-action-keymap nil + "Keymap used in an extent in the help buffer to start the action.") + +(defvar idd-help-source nil + "Contains the source of an action. Used only in the help buffer.") + +(defvar idd-help-destination nil + "Contains the destination of an action. Used only in the help buffer.") + +(defvar idd-help-start-extent nil + "The start extent in the help buffer.") + (defun idd-compare-a-specification (source-or-destination specification) "Tests if SOURCE-OR-DESTINATION matches the SPECIFICATION. @@ -108,8 +210,8 @@ '(cdr specification)))) (defun idd-compare-specifications-1 (source-or-destination - specifications - value) + specifications + value) "Internal function of `idd-compare-specifications'. VALUE is the value of the last matches." (cond ((not specifications) value) @@ -121,37 +223,37 @@ (+ value match)))))))) (defun idd-compare-specifications (source-or-destination - specifications) + specifications) "Determines how good SOURCE-OR-DESTINATION and SPECIFICATIONS are matching. A return value of zero means, that they don't match. The higher the return value the better is the matching." (cond ((not specifications) 1) (t (idd-compare-specifications-1 source-or-destination - specifications - 0)))) + specifications + 0)))) -(defun idd-get-action-depending-on-destination (destination - actions-depending-on-dest - source-value - value-action-pair) +(defun idd-get-action-depending-on-source (source + actions-depending-on-source + destination-value + value-action-pair) "Internal function of `idd-get-action-depending-on-source-and-destination'." - (let ((destination-value (idd-compare-specifications - destination - (car (car actions-depending-on-dest))))) - (cond ((not actions-depending-on-dest) value-action-pair) - ((or (= destination-value 0) - (<= (+ source-value destination-value) (car value-action-pair))) - (idd-get-action-depending-on-destination - destination - (cdr actions-depending-on-dest) - source-value + (let ((source-value (idd-compare-specifications + source + (car (car actions-depending-on-source))))) + (cond ((not actions-depending-on-source) value-action-pair) + ((or (= source-value 0) + (<= (+ destination-value source-value) (car value-action-pair))) + (idd-get-action-depending-on-source + source + (cdr actions-depending-on-source) + destination-value value-action-pair)) - (t (idd-get-action-depending-on-destination - destination - (cdr actions-depending-on-dest) - source-value - (cons (+ source-value destination-value) - (second (car actions-depending-on-dest)))))))) + (t (idd-get-action-depending-on-source + source + (cdr actions-depending-on-source) + destination-value + (cons (+ destination-value source-value) + (second (car actions-depending-on-source)))))))) (defun idd-get-action-depending-on-source-and-destination (source destination @@ -161,9 +263,10 @@ VALUE-ACTION-PAIR is a list like ( ). It returns VALUE-ACTION-PAIR, if no other action is found, which has a value higher than (car VALUE-ACTION-PAIR)." - (let ((source-value (idd-compare-specifications source (car (car actions))))) + (let ((destination-value + (idd-compare-specifications destination (car (car actions))))) (cond ((not actions) value-action-pair) - ((= source-value 0) + ((= destination-value 0) (idd-get-action-depending-on-source-and-destination source destination @@ -173,10 +276,10 @@ source destination (cdr actions) - (idd-get-action-depending-on-destination - destination + (idd-get-action-depending-on-source + source (cdr (car actions)) - source-value + destination-value value-action-pair)))))) (defun idd-get-action (source destination actions) @@ -188,6 +291,35 @@ actions '(0 . nil))) +(autoload 'ange-ftp-ftp-path "ange-ftp" + "Parse PATH according to ange-ftp-path-format (which see). +Returns a list (HOST USER PATH), or nil if PATH does not match the format.") + +(defun idd-set-point (source-or-destination) + "Sets the point and buffer to SOURCE-OR-DESTINATION." + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination)))) + +(defun idd-set-region (source-or-destination) + "Sets the point, mark and buffer to SOURCE-OR-DESTINATION. +The region is active after this function is called." + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (goto-char (car (cdr (assoc ':region-active source-or-destination)))) + (set-mark (cdr (cdr (assoc ':region-active source-or-destination)))) + (activate-region)) + + +;;; Specification type functions for the list `idd-actions' + +(defun idd-if-region-active-p (source-or-destination value) + "Checks if the region in the SOURCE-OR-DESTINATION was active. +It returns 1, if the region was active and VALUE is t, or if +the region was not active and VALUE is nil. Otherwise it returns +nil." + (if (cdr (assoc ':region-active source-or-destination)) + (if value 1 nil) + (if value nil 1))) + (defun idd-get-buffer-url (source-or-destination) "Returns the URL of the buffer specified by SOURCE-OR-DESTINATION." (save-excursion @@ -201,7 +333,7 @@ (idd-set-point source-or-destination) (w3-view-this-url t))) -(defun idd-url-at-point-p (source-or-destination value) +(defun idd-if-url-at-point-p (source-or-destination value) "Checks if there is an URL at the point of SOURCE-OR-DESTINATION. If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 is returned. Otherwise nil is returned." @@ -213,7 +345,7 @@ nil 1))) -(defun idd-major-mode-p (source-or-destination mode) +(defun idd-if-major-mode-p (source-or-destination mode) "Checks, if the major mode of SOURCE-OR-DESTINATION is MODE. It returns 1, if that is t and nil otherwise." (save-excursion @@ -222,18 +354,19 @@ 1 nil))) -(defun idd-set-point (source-or-destination) - "Sets the point and buffer to SOURCE-OR-DESTINATION." - (set-buffer (cdr (assoc ':buffer source-or-destination))) - (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination)))) +(defun idd-if-variable-non-nil-p (source-or-destination variable) + "Checks, if the variable named VARIABLE isn't t in SOURCE-OR-DESTINATION. +It returns 1, if this is t." + (save-excursion + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (if (eval variable) + 1 + nil))) -(defun idd-set-region (source-or-destination) - "Sets the point, mark and buffer to SOURCE-OR-DESTINATION. -The region is active after this function is called." - (set-buffer (cdr (assoc ':buffer source-or-destination))) - (goto-char (car (cdr (assoc ':region-active source-or-destination)))) - (set-mark (cdr (cdr (assoc ':region-active source-or-destination)))) - (activate-region)) +(defun idd-if-minor-mode-p (source-or-destination minor-mode-variable) + "Checks, if the variable MINOR-MODE-VARIABLE is t in SOURCE-OR-DESTINATION. +MINOR-MODE-VARIABLE is the name of the variable!." + (idd-variable-non-nil-p source-or-destination minor-mode-variable)) (defun idd-get-dired-filename-from-line (source-or-destination) "Returns the filename form the line in a dired buffer. @@ -242,7 +375,7 @@ (idd-set-point source-or-destination) (dired-get-filename nil t))) -(defun idd-dired-file-on-line-p (source-or-destination filename-regexp) +(defun idd-if-dired-file-on-line-p (source-or-destination filename-regexp) "Checks, if the filename on the line match FILENAME-REGEXP. The function `dired-get-filename' is used, to get the filename from the SOURCE-OR-DESTINATION. It returns 1, if it matchs or nil." @@ -254,7 +387,7 @@ 1 nil))) -(defun idd-dired-no-file-on-line-p (source-or-destination value) +(defun idd-if-dired-no-file-on-line-p (source-or-destination value) "Checks, if a filename is in the dired buffer of SOURCE-OR-DESTINATION. It returns 1, if a filename is on the line and if VALUE is t, or if no filename is on the line and VALUE is nil, otherwise it returns @@ -263,10 +396,6 @@ (if value nil 1) (if value 1 nil))) -(autoload 'ange-ftp-ftp-path "ange-ftp" - "Parse PATH according to ange-ftp-path-format (which see). -Returns a list (HOST USER PATH), or nil if PATH does not match the format.") - (defun idd-get-local-filename (source-or-destination) "Returns the filename of a local file specified by SOURCE-OR-DESTINATION." (buffer-file-name (cdr (assoc ':buffer source-or-destination)))) @@ -277,7 +406,7 @@ (idd-set-point source-or-destination) default-directory)) -(defun idd-local-file-p (source-or-destination value) +(defun idd-if-local-file-p (source-or-destination value) "Checks, if SOURCE-OR-DESTINATION has a file on the local filesystem. If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 is returned. Otherwise nil is returned." @@ -287,6 +416,137 @@ (if value 1 nil) (if value nil 1)))) +(defun idd-if-buffer-name-p (source-or-destination buffer-name) + "Checks, if SOURCE-OR-DESTINATION has a buffer called BUFFER-NAME. +It returns 1 if this is the case or nil otherwise." + (if (string= buffer-name + (buffer-name (cdr (assoc ':buffer source-or-destination)))) + 1 + nil)) + +(defun idd-list-1-subset-of-list-2 (list-1 list-2) + "Returns t, if LIST-1 is a subset of LIST-2." + (cond ((not list-1)) + ((member (car list-1 list-2)) + (idd-list-1-subset-of-list-2 (cdr list-1) list-2)) + (t nil))) + +(defun idd-same-modifiers (list-1 list-2) + "Returns t, if both list have the same modifiers." + (and (length list-1 list-2) + (idd-list-1-subset-of-list-2 list-1-list-2))) + +(defun idd-if-modifiers-p (source-or-destination modifiers) + "Checks, if the MODIFIERS hold during selecting the SOURCE-OR-DESTINATION. +Returns 1, if the list MODIFIERS contains the same modifiers, +or if any modyfiers are hold and MODIFIERS is t, +or if no modyfiers are hold and MODIFIERS is nil. +Otherwise nil is returned." + (let ((event-modifiers (event-modifiers + (cdr (assoc ':event source-or-destination))))) + (cond ((not modifiers) + (if event-modifiers nil 1)) + ((listp modifiers) + (if (idd-same-elements modifiers event-modifiers) + 1 + nil)) + (t (if event-modifiers 1 nil))))) + +;;; action functions + +(defun idd-action-copy-region (source destination) + "Copy the region from DESTINATION to SOURCE." + (idd-set-region source) + (let ((region-contents (buffer-substring (point) (mark)))) + (idd-set-point destination) + (insert region-contents))) + +(defun idd-action-copy-replace-region (source destination) + "Copy the region from SOURCE and replace the DESTINATION region with it." + (idd-set-region source) + (let ((region-contents (buffer-substring (point) (mark)))) + (idd-set-region destination) + (delete-region (point) (mark)) + (insert region-contents))) + +(defmacro* idd-with-source-and-destination (source + destination + &key + do-in-source + do-in-destination) + "Macro, usefull for the definition of action functions. +Look at the example `idd-action-move-region'." + `(progn + (if (idd-if-region-active-p ,source t) + (idd-set-region ,source) + (idd-set-point ,source)) + ,(when do-in-source + (cons 'progn do-in-source)) + (if (idd-if-region-active-p ,destination t) + (idd-set-region ,destination) + (idd-set-point ,destination)) + ,(when do-in-destination + (cons 'progn do-in-destination)))) + +(defun idd-action-move-region (source destination) + "Move the region from SOURCE to DESTINATION." + (let ((region)) + (idd-with-source-and-destination + source destination + :do-in-source ((setq region (buffer-substring (point) (mark))) + (delete-region (point) (mark))) + :do-in-destination ((insert region))))) + + +(defun idd-action-move-replace-region (source destination) + "Delete the region at SOURCE and overwrite the DESTINATION region with it." + (let ((region)) + (idd-with-source-and-destination + source destination + :do-in-source ((setq region (buffer-substring (point) (mark))) + (delete-region (point) (mark))) + :do-in-destination ((delete-region (point) (mark)) + (insert region))))) + + +;;; Performing the drag and drop + +(defun idd-display-help-about-action (action source destination) + "Display a help buffer with information about the action." + (if (> (car action) 0) + (if (symbol-function (cdr action)) + (progn + (with-displaying-help-buffer + '(lambda () + (set-buffer "*Help*") + (setq idd-help-source source) + (setq idd-help-destination destination) + (insert "Drag and drop action: `") + (let ((start (point))) + (insert (format "%s" (cdr action))) + (setq idd-help-start-extent (make-extent start (point))) + (set-extent-mouse-face idd-help-start-extent 'highlight) + (set-extent-face idd-help-start-extent 'bold) + (set-extent-keymap idd-help-start-extent + idd-help-start-action-keymap) + ) + (insert "'\n") + (insert (format "Source buffer : `%s'\n" + (buffer-name (cdr (assoc ':buffer source))))) + (insert (format "Destination buffer : `%s'\n" + (buffer-name (cdr (assoc ':buffer destination)) + ))) + (insert "==================================================" + "====================\n") + (insert "Look at `idd-actions' in the " + "destination buffer for other actions!\n") + (insert (format "The documentation of `%s':\n\n" + (cdr action))) + (insert (documentation (cdr action))))) + ) + (error "Error: Action %s isn't a valid function!" (cdr action))) + (message "No valid action defined for this source and this destination!"))) + (defun idd-call-action (action source destination) "Calls the drag and drop ACTION with its arguments SOURCE and DESTINATION." (if (> (car action) 0) @@ -295,35 +555,170 @@ (error "Error: Action %s isn't a valid function!" (cdr action))) (message "No valid action defined for this source and this destination!"))) +(defun idd-start-help-mouse-drag-and-drop () + "Starts help on `idd-start-mouse-drag-and-drop'." + (interactive) + (let ((idd-help-instead-of-action t)) + (idd-start-mouse-drag-and-drop))) + +(defun idd-start-mouse-drag-and-drop () + "Starts a drag and drop command. +This command could be used to start a drag and drop command without a +button event. Therefore this should not be bind direct to a mouse button." + (interactive) + (let ((destination-event) + (drag-and-drop-message "Drag&Drop: Click on the source!")) + (message drag-and-drop-message) + (setq source-event + (next-command-event nil drag-and-drop-message)) + (if (button-press-event-p source-event) + (idd-mouse-drag-and-drop source-event) + (message "Wrong event! Exit drag and drop.")))) + +(defun idd-help-mouse-drag-and-drop (source-event) + "Displays help about the drag and drop action." + (interactive "@e") + (let ((idd-help-instead-of-action t)) + (idd-mouse-drag-and-drop source-event))) + (defun idd-mouse-drag-and-drop (source-event) "Performs a drag and drop action. -At first you must click on the source and after that on the destination." +It calls the command `idd-mouse-drag-and-drop-click' or +`idd-mouse-drag-and-drop-press-button-during-move' depending on +the value of `idd-drag-and-drop-mouse-binding-type'." (interactive "@e") - (let ((source (list (cons ':buffer (current-buffer)) - (cons ':drag-or-drop-point - (event-closest-point source-event)) - (cons ':region-active (if (region-active-p) - (cons (point) - (mark)))))) + (if (eq idd-drag-and-drop-mouse-binding-type 'click) + (idd-mouse-drag-and-drop-click source-event) + (idd-mouse-drag-and-drop-press-button-during-move source-event))) + +(defun idd-get-source-or-destination-alist (event) + "Returns an alist with the description of a source or destination point. +The EVENT must be the button event, which has selected the source or +destination of the drag and drop command. + +The alist has the following structure: + '((:buffer . ) + (:drag-or-drop-point . ) + (:region-active . ) + (:event . EVENT)) + +Note: is (event-closest-point EVENT), +if the EVENT is a mouse event and if it isn't nil. Otherwise the +point is used." +; (set-buffer (event-buffer event)) + (list (cons ':buffer (event-buffer event)) + (cons ':drag-or-drop-point (set-marker + (make-marker) + (if (mouse-event-p event) + (or (event-closest-point event) + (point)) + (point)))) + (cons ':region-active (if (region-active-p) + (cons (set-marker (make-marker) (point)) + (set-marker (make-marker) (mark))))) + (cons ':event event)) + ) + +(defun idd-mouse-drag-and-drop-press-button-during-move (source-event) + "Performs a drag and drop action. +At first you must press the button down over the source and then +move with the pressed button to the destination, where you must leave +the button up. +This must be bind to a mouse button. The SOURCE-EVENT must be a +button-press-event. + +The disadvantage of this command compared with the command +`idd-mouse-drag-and-drop-click' is, that you can't select a +destination region." + (interactive "@e") + (let ((drag-and-drop-message + "Drag&Drop: Leave the button over the destination!") + (source (idd-get-source-or-destination-alist source-event)) (destination nil) (destination-event)) - (if (adapt-xemacsp) + (message drag-and-drop-message) + (setq destination-event + (next-command-event nil drag-and-drop-message)) + (message "") + (cond ((button-release-event-p destination-event) + (setq destination (idd-get-source-or-destination-alist + destination-event)) + (idd-set-point destination) + (if idd-help-instead-of-action + (idd-display-help-about-action (idd-get-action source + destination + idd-actions) + source + destination) + (idd-call-action (idd-get-action source destination idd-actions) + source + destination))) + (t (message "Wrong event! Exit drag and drop.") nil)))) + +(defun idd-mouse-drag-and-drop-click (source-event) + "Performs a drag and drop action. +At first you must click on the source and after that on the destination. +This must be bind to a mouse button. The SOURCE-EVENT must be a +button-press-event." + (interactive "@e") + (let ((drag-and-drop-message "Drag&Drop: Click on the destination!") + (source (idd-get-source-or-destination-alist source-event)) + (destination nil) + (destination-event)) + (message drag-and-drop-message) + (if (and (adapt-xemacsp) (mouse-event-p source-event)) (dispatch-event (next-command-event))) (setq destination-event - (next-command-event nil "Drag&Drop: Click on the destination!")) + (next-command-event nil drag-and-drop-message)) +(setq heiko source-event) + (message "") (cond ((button-press-event-p destination-event) - (setq destination (list (cons ':buffer - (event-buffer destination-event)) - (cons ':drag-or-drop-point - (event-closest-point - destination-event)) - (cons ':region-active nil))) + (mouse-track destination-event) + (setq destination (idd-get-source-or-destination-alist + destination-event)) + (idd-set-point destination) (if (adapt-emacs19p) (while (not (button-release-event-p (next-command-event))))) - (idd-call-action (idd-get-action source destination idd-actions) - source - destination)) - (t (setq action "Wrong event") nil)))) + (if idd-help-instead-of-action + (idd-display-help-about-action (idd-get-action source + destination + idd-actions) + source + destination) + (idd-call-action (idd-get-action source destination idd-actions) + source + destination))) + (t (message "Wrong event! Exit drag and drop.") nil)))) + +(defun idd-help-start-action (event) + "Used to start the action from the help buffer." + (interactive "@e") + (idd-set-point idd-help-destination) + (idd-call-action (idd-get-action idd-help-source + idd-help-destination + idd-actions) + idd-help-source + idd-help-destination) + (delete-extent idd-help-start-extent)) + +;; keymap for help buffer extents +(if (not idd-help-start-action-keymap) + (progn + (setq idd-help-start-action-keymap + (make-sparse-keymap 'idd-help-start-action-keymap)) + (if (adapt-emacs19p) + (define-key idd-help-start-action-keymap [(mouse-2)] + 'idd-help-start-action) + (define-key idd-help-start-action-keymap "[(button2)]" + 'idd-help-start-action)))) + +;; global key bindings +(when idd-global-mouse-keys + (unless (where-is-internal 'idd-mouse-drag-and-drop global-map t) + (define-key global-map idd-global-mouse-keys 'idd-mouse-drag-and-drop)) + (unless (where-is-internal 'idd-help-mouse-drag-and-drop global-map t) + (define-key global-map + idd-global-help-mouse-keys 'idd-help-mouse-drag-and-drop))) (provide 'internal-drag-and-drop) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/hm--html-menus/tmpl-minor-mode.el Binary file lisp/hm--html-menus/tmpl-minor-mode.el has changed diff -r 498bf5da1c90 -r 0d2f883870bc lisp/modes/executable.el --- a/lisp/modes/executable.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/modes/executable.el Mon Aug 13 09:13:56 2007 +0200 @@ -211,7 +211,8 @@ (y-or-n-p (concat "Replace magic number by `" executable-prefix argument "'? ")))) (progn - (replace-match argument t t nil 1) + (replace-match (concat executable-prefix argument) + t t nil 1) (message "Magic number changed to `%s'" (concat executable-prefix argument))))) (insert executable-prefix argument ?\n) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/modes/lisp-mode.el --- a/lisp/modes/lisp-mode.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/modes/lisp-mode.el Mon Aug 13 09:13:56 2007 +0200 @@ -367,10 +367,7 @@ (if (and (consp expr) (eq (car expr) 'defvar) (> (length expr) 2)) - (progn (eval (cons 'defconst (cdr expr))) - (message "defvar treated as defconst") - (sit-for 1) - (message "")) + (eval (cons 'defconst (cdr expr))) (eval expr))) (defun eval-last-sexp (eval-last-sexp-arg-internal) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/modes/python-mode.el --- a/lisp/modes/python-mode.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/modes/python-mode.el Mon Aug 13 09:13:56 2007 +0200 @@ -2,12 +2,12 @@ ;; Copyright (C) 1992,1993,1994 Tim Peters -;; Author: 1995-1996 Barry A. Warsaw +;; Author: 1995-1997 Barry A. Warsaw ;; 1992-1994 Tim Peters ;; Maintainer: python-mode@python.org ;; Created: Feb 1992 -;; Version: 2.83 -;; Last Modified: 1996/10/23 20:44:59 +;; Version: 2.89 +;; Last Modified: 1997/01/30 20:16:18 ;; Keywords: python languages oop ;; This software is provided as-is, without express or implied @@ -275,6 +275,9 @@ (and (fboundp 'make-obsolete-variable) (make-obsolete-variable 'py-mode-hook 'python-mode-hook)) +(defvar py-delete-function 'backward-delete-char-untabify + "*Function called by `py-delete-char' when deleting characters.") + (defvar py-mode-map () "Keymap used in `python-mode' buffers.") @@ -407,6 +410,26 @@ If you change this, you probably have to change `py-current-defun' as well. This is only used by `py-current-defun' to find the name for add-log.el.") +;; As of 30-Jan-1997, Emacs 19.34 works but XEmacs 19.15b90 and +;; previous does not. It is suspected that Emacsen before 19.34 are +;; also broken. +(defvar py-parse-partial-sexp-works-p + (let ((buf (get-buffer-create " ---*---pps---*---")) + state status) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert "(line1\n line2)\nline3") + (lisp-mode) + (goto-char (point-min)) + (setq state (parse-partial-sexp (point) (save-excursion + (forward-line 1) + (point)))) + (parse-partial-sexp (point) (point-max) 0 nil state) + (setq status (not (= (point) (point-max)))) + (kill-buffer buf) + status)) + "Does `parse-partial-sexp' work in this Emacs?") ;; Menu definitions, only relevent if you have the easymenu.el package @@ -424,8 +447,8 @@ (easy-menu-define py-menu py-mode-map "Python Mode menu" '("Python" - ["Comment Out Region" comment-region (mark)] - ["Uncomment Region" (comment-region (point) (mark) '(4)) (mark)] + ["Comment Out Region" py-comment-region (mark)] + ["Uncomment Region" (py-comment-region (point) (mark) '(4)) (mark)] "-" ["Mark current block" py-mark-block t] ["Mark current def" mark-python-def-or-class t] @@ -682,6 +705,7 @@ (make-local-variable 'paragraph-start) (make-local-variable 'require-final-newline) (make-local-variable 'comment-start) + (make-local-variable 'comment-end) (make-local-variable 'comment-start-skip) (make-local-variable 'comment-column) (make-local-variable 'indent-region-function) @@ -697,6 +721,7 @@ paragraph-start "^[ \t]*$" require-final-newline t comment-start "# " + comment-end "" comment-start-skip "# *" comment-column 40 indent-region-function 'py-indent-region @@ -990,7 +1015,10 @@ ;; Functions for Python style indentation (defun py-delete-char (count) "Reduce indentation or delete character. + If point is at the leftmost column, deletes the preceding newline. +Deletion is performed by calling the function in `py-delete-function' +with a single argument (the number of characters to delete). Else if point is at the leftmost non-blank character of a line that is neither a continuation line nor a non-indenting comment line, or if @@ -1009,7 +1037,7 @@ (py-continuation-line-p) (not py-honor-comment-indentation) (looking-at "#[^ \t\n]")) ; non-indenting # - (backward-delete-char-untabify count) + (funcall py-delete-function count) ;; else indent the same as the colon line that opened the block ;; force non-blank so py-goto-block-up doesn't ignore it @@ -2195,9 +2223,9 @@ (if (and (not (zerop (car state))) (not (eobp))) (progn - ;; BUG ALERT: I could swear, from reading the docs, that - ;; the 3rd argument should be plain 0 - (parse-partial-sexp (point) (point-max) (- 0 (car state)) + (parse-partial-sexp (point) (point-max) + (if py-parse-partial-sexp-works-p + 0 (- 0 (car state))) nil state) (forward-line 1)))))) @@ -2361,6 +2389,15 @@ (set-buffer cbuf)) (sit-for 0)) +;; older Emacsen don't have this function +(if (not (fboundp 'match-string)) + (defun match-string (n) + (let ((beg (match-beginning n)) + (end (match-end n))) + (if (and beg end) + (buffer-substring beg end) + nil)))) + (defun py-current-defun () ;; tell add-log.el how to find the current function/method/variable (save-excursion @@ -2374,7 +2411,7 @@ nil))) -(defconst py-version "2.83" +(defconst py-version "2.89" "`python-mode' version number.") (defconst py-help-address "python-mode@python.org" "Address accepting submission of bug reports.") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/modes/sh-script.el --- a/lisp/modes/sh-script.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/modes/sh-script.el Mon Aug 13 09:13:56 2007 +0200 @@ -49,6 +49,49 @@ (require 'executable) +;;; interpreter-mode-alist is not compatible between Emacs and XEmacs. +;;; So fake it. + +(defvar sh-interpreter-mode-alist + '(("perl" . perl-mode) + ("perl5" . perl-mode) + ("wish" . tcl-mode) + ("wishx" . tcl-mode) + ("tcl" . tcl-mode) + ("tclsh" . tcl-mode) + ("awk" . awk-mode) + ("mawk" . awk-mode) + ("nawk" . awk-mode) + ("gawk" . awk-mode) + ("scm" . scheme-mode) + ("ash" . sh-mode) + ("bash" . sh-mode) + ("csh" . sh-mode) + ("dtksh" . sh-mode) + ("es" . sh-mode) + ("itcsh" . sh-mode) + ("jsh" . sh-mode) + ("ksh" . sh-mode) + ("oash" . sh-mode) + ("pdksh" . sh-mode) + ("rc" . sh-mode) + ("sh" . sh-mode) + ("sh5" . sh-mode) + ("tcsh" . sh-mode) + ("wksh" . sh-mode) + ("wsh" . sh-mode) + ("zsh" . sh-mode) + ("tail" . text-mode) + ("more" . text-mode) + ("less" . text-mode) + ("pg" . text-mode)) + "Alist mapping interpreter names to major modes. +This alist applies to files whose first line starts with `#!'. +Each element looks like (INTERPRETER . MODE). +The car of each element is compared with +the name of the interpreter specified in the first line. +If it matches, mode MODE is selected.") + (defvar sh-ancestor-alist '((ash . sh) (bash . jsh) @@ -672,6 +715,15 @@ ;;;###autoload (defalias 'shell-script-mode 'sh-mode) +;;; XEmacs +(put 'sh-mode 'font-lock-defaults + `((sh-font-lock-keywords + sh-font-lock-keywords-1 + sh-font-lock-keywords-2) + ,sh-font-lock-keywords-only + nil + ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")))) + (defun sh-font-lock-keywords (&optional keywords) "Function to get simple fontification based on `sh-font-lock-keywords'. @@ -719,7 +771,8 @@ Makes this script executable via `executable-set-magic'. Calls the value of `sh-set-shell-hook' if set." (interactive (list (completing-read "Name or path of shell: " - interpreter-mode-alist + ;; XEmacs change + sh-interpreter-mode-alist (lambda (x) (eq (cdr x) 'sh-mode))) (eq executable-query 'function) t)) @@ -729,8 +782,10 @@ (setq sh-shell-file (executable-set-magic shell (sh-feature sh-shell-arg))) (setq require-final-newline (sh-feature sh-require-final-newline) ;;; local-abbrev-table (sh-feature sh-abbrevs) - font-lock-keywords nil ; force resetting - font-lock-syntax-table nil + font-lock-defaults-computed nil + ;; Next two lines kill XEmacs + ;font-lock-keywords nil ; force resetting + ;font-lock-syntax-table nil comment-start-skip (concat (sh-feature sh-comment-prefix) "#+[\t ]*") mode-line-process (format "[%s]" sh-shell) sh-shell-variables nil @@ -742,7 +797,9 @@ (setq shell (cdr shell))) (and (boundp 'font-lock-mode) font-lock-mode + ;; Gnu Emacs, doesn't work (font-lock-mode (font-lock-mode 0))) + ;; (font-lock-fontify-buffer)) (run-hooks 'sh-set-shell-hook)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/modes/verilog-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/modes/verilog-mode.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,3078 @@ +;;; verilog-mode.el --- major mode for editing verilog source in Emacs + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Michael McNamara (mac@silicon-sorcery.com) +;; President, Silicon Sorcery +;; Keywords: languages + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs/lisp/modes/Attic/verilog-mode.el,v 1.1 1997/02/13 18:52:49 steve Exp $ +;; For help figuring out what to do with this file, visit +;; + +;; This mode borrows heavily from the pascal-mode and the cc-mode of emacs + +;; USAGE +;; ===== + +;; A major mode for editing Verilog HDL source code. When you have +;; entered Verilog mode, you may get more info by pressing C-h m. You +;; may also get online help describing various functions by: C-h f +;; + +;; To set up automatic verilog mode, put this file in your load path, +;; and include stuff like this in your .emacs: + +;; (autoload 'verilog-mode "verilog-mode" "Verilog mode" t ) +;; (setq auto-mode-alist (cons '("\\.v\\'" . verilog-mode) auto-mode-alist)) +;; (setq auto-mode-alist (cons '("\\.dv\\'" . verilog-mode) auto-mode-alist)) + +;; If you want to customize Verilog mode to fit your needs better, +;; you may add these lines (the values of the variables presented +;; here are the defaults): +;; +;; ;; User customization for Verilog mode +;; (setq verilog-indent-level 3 +;; verilog-case-indent 2 +;; verilog-auto-newline t +;; verilog-auto-indent-on-newline t +;; verilog-tab-always-indent t +;; verilog-auto-endcomments t +;; verilog-minimum-comment-distance 40 +;; verilog-indent-begin-after-if t +;; verilog-auto-lineup '(all)) + +;; I've put in the common support for colored displays for older +;; emacs-19 behaviour, and newer emacs-19 behaviour, as well as +;; support for xemacs. After that, customizing according to your +;; particular emacs version is up to you. I've used the following +;; for emacs 19.27 and emacs 19.30; also xemacs seems to work for me +;; as well. I must caution that since the font-lock package doesn't +;; have a version number, I've had to key off the emacs version +;; number, which might not corrolate with the font-lock package you +;; happen to be using... + +;; Cut the following (From ";;;; - HERE - " to ";;;; - THERE -") and +;; place the text in your .emacs file. The delete all the single ; +;; at the beginning of the lines. + +;; (If you set the mark at the word HERE, (get cursor of the word +;; and type C-@) and point at word THERE, and then type C-u M-x +;; comment-region it will magically delete all the ; for you) + +;; As coded this should work for modern versions of emacs, and also +;; should be a basis where you could build from to get colors for +;; other modes. It owes a fair bit to the excellent sample.emacs +;; from Xemacs. + + +;; ;;; - HERE - +;;(defvar background-mode 'light) +;;(defvar display-type 'color) +;; ;; figure out background color. We could ask the user, but that would be too easy +;;(cond +;; ((and +;; (fboundp 'device-type) +;; (string= "x" (device-type))) +;; (setq display-type (device-class) +;; background-mode +;; (condition-case nil +;; (let ((bg-resource (x-get-resource ".backgroundMode" "BackgroundMode" 'string)) +;; (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")) 3))) +;; 'dark) +;; ((and (cdr (assq 'border-color params)) +;; (> (apply '+ (color-instance-rgb-components +;; (make-color-instance (cdr (assq 'border-color params))))) +;; (/ 255 3))) +;; 'dark) +;; (t 'light))) +;; (error 'light)) +;; ) +;; ) +;; ((and +;; (boundp 'window-system) +;; (string= window-system "x")) +;; (setq 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)) +;; ) +;; (setq 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")) 3))) +;; 'dark) +;; ((and (fboundp 'color-instance-rgb-components ) +;; (cdr (assq 'border-color params)) +;; (> (apply '+ (color-instance-rgb-components +;; (make-color-instance (cdr (assq 'border-color params))))) +;; (/ 255 3))) +;; 'dark) +;; (t 'light))) +;; (error 'light)) +;; ) +;; )) + +;;(message "It appears you have a %s background" background-mode) + +;; ; Now do emacs version specific color setup +;;(cond +;; ((and (string-match "XEmacs" emacs-version) +;; (boundp 'emacs-major-version) +;; (= emacs-major-version 19) +;; (>= emacs-minor-version 12)) + +;; ;; If you want the default colors, you could do this: +;; ;; (setq font-lock-use-default-fonts nil) +;; ;; (setq font-lock-use-default-colors t) +;; ;; but I want to specify my own colors, so I turn off all +;; ;; default values. +;; (setq font-lock-use-default-fonts nil) +;; (setq font-lock-use-default-colors nil) +;; (require 'font-lock) + +;; ;; Mess around with the faces a bit. Note that you have +;; ;; to change the font-lock-use-default-* variables *before* +;; ;; loading font-lock, and wait till *after* loading font-lock +;; ;; to customize the faces. + +;; ;; (use copy-face instead of make-face-italic/make-face-bold because +;; ;; the startup code does intelligent things to the 'italic and 'bold +;; ;; faces to ensure that they are different from the default face. +;; ;; For example, if the default face is bold, then the 'bold face +;; ;; will be unbold.) +;; ;; Underling comments looks terrible on tty's +;; (set-face-underline-p 'font-lock-comment-face nil 'global 'tty) +;; (set-face-highlight-p 'font-lock-comment-face t 'global 'tty) + +;; (make-face-unitalic 'font-lock-comment-face) +;; (make-face-unitalic 'font-lock-string-face) +;; (copy-face 'bold 'font-lock-function-name-face) +;; (cond +;; ((eq background-mode 'light) +;; (set-face-foreground 'font-lock-comment-face "orchid") +;; (set-face-foreground 'font-lock-function-name-face "red") +;; (set-face-foreground 'font-lock-keyword-face "blue") +;; (set-face-foreground 'font-lock-string-face "steelblue") +;; (set-face-foreground 'font-lock-type-face "darkgreen") +;; ) +;; ((eq background-mode 'dark) +;; (set-face-foreground 'font-lock-comment-face "#efc80c") +;; (set-face-foreground 'font-lock-function-name-face "red") +;; (set-face-foreground 'font-lock-keyword-face "tan") +;; (set-face-foreground 'font-lock-string-face "lightskyblue") +;; (set-face-foreground 'font-lock-type-face "Aquamarine") +;; ) +;; ) +;; ;; misc. faces +;; (and (find-face 'font-lock-preprocessor-face) ; 19.13 and above +;; (copy-face 'bold 'font-lock-preprocessor-face)) +;; ) +;; ((> emacs-minor-version 29) +;; (if (eq background-mode 'light) +;; (setq font-lock-face-attributes +;; '( +;; (font-lock-comment-face "orchid" nil nil t nil) +;; (font-lock-function-name-face "red" nil t nil nil) +;; (font-lock-keyword-face "blue" nil nil nil nil) +;; (font-lock-reference-face "indianred" nil t nil nil ) +;; (font-lock-string-face "steelblue" nil nil nil nil) +;; (font-lock-type-face "darkgreen" nil nil nil nil) +;; (font-lock-variable-name-face "brown") +;; ) +;; ) +;; (setq font-lock-face-attributes +;; '( +;; (font-lock-comment-face "#efc80c" nil nil t nil) +;; (font-lock-function-name-face "red" nil t nil nil) +;; (font-lock-keyword-face "tan" nil nil nil nil) +;; (font-lock-reference-face "indianred" nil t nil nil ) +;; (font-lock-string-face "lightskyblue" nil nil nil nil) +;; (font-lock-type-face "Aquamarine" nil nil nil nil) +;; (font-lock-variable-name-face "LightGoldenrod") +;; ) +;; ) +;; ) +;; ) +;; (t +;; (if (eq background-mode 'dark) +;; (progn +;; (make-face 'my-font-lock-function-name-face) +;; (set-face-foreground 'my-font-lock-function-name-face "red") +;; (setq font-lock-function-name-face 'my-font-lock-function-name-face) + +;; (make-face 'my-font-lock-keyword-face) +;; (set-face-foreground 'my-font-lock-keyword-face "tan") +;; (setq font-lock-keyword-face 'my-font-lock-keyword-face) + +;; (make-face 'my-font-lock-string-face) +;; (set-face-foreground 'my-font-lock-string-face "lightskyblue") +;; (setq font-lock-string-face 'my-font-lock-string-face) + +;; (make-face 'my-font-lock-type-face) +;; (set-face-foreground 'my-font-lock-type-face "#efc80c") ; yellow +;; (setq font-lock-type-face 'my-font-lock-type-face) + +;; (make-face 'my-font-lock-variable-name-face) +;; (set-face-foreground 'my-font-lock-variable-name-face "LightGoldenrod") +;; (setq font-lock-variable-name-face 'my-font-lock-variable-name-face) +;; ) +;; (progn +;; (make-face 'my-font-lock-function-name-face) +;; (set-face-foreground 'my-font-lock-function-name-face "DarkGreen") +;; (setq font-lock-function-name-face 'my-font-lock-function-name-face) + +;; (make-face 'my-font-lock-keyword-face) +;; (set-face-foreground 'my-font-lock-keyword-face "indianred") +;; (setq font-lock-keyword-face 'my-font-lock-keyword-face) + +;; (make-face 'my-font-lock-string-face) +;; (set-face-foreground 'my-font-lock-string-face "RoyalBlue") +;; (setq font-lock-string-face 'my-font-lock-string-face) + +;; (make-face 'my-font-lock-type-face) +;; (set-face-foreground 'my-font-lock-type-face "#003800") ; yellow +;; (setq font-lock-type-face 'my-font-lock-type-face) + +;; (make-face 'my-font-lock-variable-name-face) +;; (set-face-foreground 'my-font-lock-variable-name-face "LightGoldenrod") +;; (setq font-lock-variable-name-face 'my-font-lock-variable-name-face) +;; ) +;; ) +;; ) +;; ) + +;;(cond +;; ((eq display-type 'color) +;; ;; Pretty Colors in source windows. +;; (require 'font-lock) +;; (autoload 'turn-on-fast-lock "fast-lock" +;; "Unconditionally turn on Fast Lock mode.") +;; (add-hook 'c-mode-hook 'font-lock-mode) +;; (add-hook 'verilog-mode-hook 'font-lock-mode) +;; (add-hook 'perl-mode-hook 'font-lock-mode) +;; (add-hook 'elisp-mode-hook 'font-lock-mode) +;; (add-hook 'asm-mode-hook 'font-lock-mode) +;; (setq fast-lock-cache-directories '("~/.backups" ".")) +;; (setq c-font-lock-keywords c-font-lock-keywords-2) +;; (setq c++-font-lock-keywords c++-font-lock-keywords-2) +;; (autoload 'verilog-make-faces "verilog-mode" "Set up faces for verilog") +;; (if (not (string-match "XEmacs" emacs-version)) +;; (progn +;; (cond +;; ((eq background-mode 'dark) +;; ;; Make background a light gray +;; (set-face-background (quote region) "gray30")) +;; ;; Make background a dark gray +;; ((eq background-mode 'light) +;; (set-face-background (quote region) "gray70")) +;; ) +;; ) +;; ) +;; ) +;; ((eq display-type 'mono) +;; (progn +;; ;; Frames are too expensive to create +;; ;; on my NCD running x-remote, which happens +;; ;; to be the only place I run X mono color +;; (setq vm-frame-per-composition nil +;; vm-frame-per-folder nil) +;; ) +;; ) +;; ) +;; ;;; - THERE - + +;; KNOWN BUGS / BUGREPORTS +;; ======================= This is beta code, and likely has +;; bugs. Please report any and all bugs to me at mac@silicon-sorcery.com. +;; + +;;; Code: + +(provide 'verilog-mode) + +;; This variable will always hold the version number of the mode +(defconst verilog-mode-version "$$Revision: 1.1 $$" + "Version of this verilog mode.") + +(defvar verilog-indent-level 3 + "*Indentation of Verilog statements with respect to containing block.") + +(defvar verilog-cexp-indent 1 + "*Indentation of Verilog statements split across lines.") + +(defvar verilog-case-indent 2 + "*Indentation for case statements.") + +(defvar verilog-auto-newline t + "*Non-nil means automatically newline after semicolons") + +(defvar verilog-auto-indent-on-newline t + "*Non-nil means automatically indent line after newline") + +(defvar verilog-tab-always-indent t + "*Non-nil means TAB in Verilog mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defvar verilog-indent-begin-after-if t + "*If true, indent begin statements following if, else, while, for and repeat. +otherwise, line them up.") + +(defvar verilog-auto-endcomments t + "*Non-nil means a comment /* ... */ is set after the ends which ends cases and +functions. The name of the function or case will be set between the braces.") + +(defvar verilog-minimum-comment-distance 40 + "*Minimum distance between begin and end required before a comment will be inserted. +Setting this variable to zero results in every end aquiring a comment; the default avoids +too many redundanet comments in tight quarters") + +(defvar verilog-auto-lineup '(all) "*List of contexts where auto + lineup of :'s or ='s should be done. Elements can be of type: + 'declaration' or 'case', which will do auto lineup in declarations + or case-statements respectively. The word 'all' will do all + lineups. '(case declaration) for instance will do lineup in + case-statements and parameterlist, while '(all) will do all + lineups." ) + +(defvar verilog-mode-abbrev-table nil + "Abbrev table in use in Verilog-mode buffers.") + +(defvar verilog-font-lock-keywords-after-1930 + '( + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*" + 1 font-lock-keyword-face) + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*\\(\\sw+\\)" + 2 font-lock-function-name-face nil t) + ("\\\\[^ \t]*" 0 'font-lock-function-name-face) ( + "\\(@\\)\\|\\(#\[ \t\]*\\(\\(\[0-9\]+\\('[hdxbo][0-9_xz]*\\)?\\)\\|\\((\[^)\]*)\\)\\)\\)" + 0 font-lock-type-face) + ("\\(`[ \t]*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-type-face) + ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" + 0 font-lock-type-face) + ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" + 0 font-lock-keyword-face) + ) +) +(defvar verilog-font-lock-keywords nil) +(defvar verilog-font-lock-keywords-before-1930 + '( + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*" . 1) + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*\\(\\sw+\\)" + 2 font-lock-function-name-face nil t) + ("\\(\\\\[^ \t]*\\)\\|\\(`[ \t]*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-function-name-face) + ("[@#]" . font-lock-type-face) + ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" + 0 font-lock-type-face) + ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" . font-lock-keyword-face) + ) +) + +(defvar verilog-imenu-generic-expression + '("^[ \t]*\\(module\\|macromodule\\|primitive\\)[ \t\n]+\\([a-zA-Z0-9_.:]+\\)" . (2)) + "Imenu expression for Verilog-mode. See `imenu-generic-expression'.") + +(defvar verilog-mode-abbrev-table nil + "Abbrev table in use in Verilog-mode buffers.") + + +(define-abbrev-table 'verilog-mode-abbrev-table ()) + +(defvar verilog-mode-map () + "Keymap used in Verilog mode.") +(if verilog-mode-map + () + (setq verilog-mode-map (make-sparse-keymap)) + (define-key verilog-mode-map ";" 'electric-verilog-semi) + (define-key verilog-mode-map ":" 'electric-verilog-colon) + (define-key verilog-mode-map "=" 'electric-verilog-equal) + (define-key verilog-mode-map "\`" 'electric-verilog-tick) + (define-key verilog-mode-map "\t" 'electric-verilog-tab) + (define-key verilog-mode-map "\r" 'electric-verilog-terminate-line) + (define-key verilog-mode-map "\M-\C-b" 'electric-verilog-backward-sexp) + (define-key verilog-mode-map "\M-\C-f" 'electric-verilog-forward-sexp) + (define-key verilog-mode-map "\M-\r" (function (lambda () + (interactive) (electric-verilog-terminate-line 1)))) + (define-key verilog-mode-map "\177" 'backward-delete-char-untabify) + (define-key verilog-mode-map "\M-\t" 'verilog-complete-word) + (define-key verilog-mode-map "\M-?" 'verilog-show-completions) + (define-key verilog-mode-map "\M-\C-h" 'verilog-mark-defun) + (define-key verilog-mode-map "\C-c\C-b" 'verilog-insert-block) + (define-key verilog-mode-map "\C-cb" 'verilog-label-be) + (define-key verilog-mode-map "\M-*" 'verilog-star-comment) + (define-key verilog-mode-map "\C-c\C-c" 'verilog-comment-area) + (define-key verilog-mode-map "\C-c\C-u" 'verilog-uncomment-area) + (define-key verilog-mode-map "\M-\C-a" 'verilog-beg-of-defun) + (define-key verilog-mode-map "\M-\C-e" 'verilog-end-of-defun) + (define-key verilog-mode-map "\C-c\C-d" 'verilog-goto-defun) + ) + + + +;;; +;;; Regular expressions used to calculate indent, etc. +;;; +(defconst verilog-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") +(defconst verilog-case-re "\\(\\[^:]\\)") +;; Want to match +;; aa : +;; aa,bb : +;; a[34:32] : +;; a, +;; b : +(defconst verilog-no-indent-begin-re "\\<\\(if\\|else\\|while\\|for\\|repeat\\|always\\)\\>") +(defconst verilog-endcomment-reason-re + (concat + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|" + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\(\[ \t\]*@\\)?\\)\\|" + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|" + "#")) + +(defconst verilog-named-block-re "begin[ \t]*:") +(defconst verilog-beg-block-re "\\<\\(begin\\|case\\|casex\\|casez\\|fork\\|table\\|specify\\)\\>") +(defconst verilog-beg-block-re-1 "\\<\\(begin\\)\\|\\(case[xz]?\\)\\|\\(fork\\)\\|\\(table\\)\\|\\(specify\\)\\|\\(function\\)\\|\\(task\\)\\>") +(defconst verilog-end-block-re "\\<\\(end\\|join\\|endcase\\|endtable\\|endspecify\\)\\>") +(defconst verilog-end-block-re-1 "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") +(defconst verilog-declaration-re + (concat "\\(\\\\|" + "\\\\|\\\\|\\\\|\\\\|" + "\\\\|" + "\\\\|\\\\|" + "\\\\|\\\\)")) +(defconst verilog-declaration-re-1 (concat "^[ \t]*" verilog-declaration-re "[ \t]*\\(\\[[^]]*\\][ \t]*\\)?")) +(defconst verilog-defun-re "\\<\\(module\\|macromodule\\|primitive\\)\\>") +(defconst verilog-end-defun-re "\\<\\(endmodule\\|endprimitive\\)\\>") +(defconst verilog-zero-indent-re + (concat verilog-defun-re "\\|" verilog-end-defun-re)) +(defconst verilog-directive-re + "\\(`else\\)\\|\\(`ifdef\\)\\|\\(`endif\\)\\|\\(`define\\)\\|\\(`undef\\)\\|\\(`include\\)") +(defconst verilog-autoindent-lines-re + (concat + "\\<\\(\\(macro\\)?module\\|primitive\\|end\\(case\\|function\\|task\\|module\\|primitive\\|specify\\|table\\)?\\|join\\|begin\\|else\\)\\>\\|`\\(else\\|ifdef\\|endif\\)\\|" + verilog-directive-re + "\\>")) +(defconst verilog-behavorial-block-beg-re + "\\(\\\\|\\\\|\\\\|\\\\)") +(defconst verilog-indent-reg + (concat "\\(\\\\|\\[^:]\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\)\\|" + "\\(\\\\|\\\\)\\|" + "\\(\\\\|\\\\)" +;; "\\|\\(\\\\|\\\\)" + )) +(defconst verilog-complete-reg + "\\(\\\\)\\|\\(\\\\)\\|\\(\\[^:]\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") +(defconst verilog-end-statement-re + (concat "\\(" verilog-beg-block-re "\\)\\|\\(" + verilog-end-block-re "\\)")) +(defconst verilog-endcase-re + (concat verilog-case-re "\\|" + "\\(endcase\\)\\|" + verilog-defun-re + )) +;;; Strings used to mark beginning and end of excluded text +(defconst verilog-exclude-str-start "/* -----\\/----- EXCLUDED -----\\/-----") +(defconst verilog-exclude-str-end " -----/\\----- EXCLUDED -----/\\----- */") + +(defconst verilog-emacs-features + (let ((major (and (boundp 'emacs-major-version) + emacs-major-version)) + (minor (and (boundp 'emacs-minor-version) + emacs-minor-version)) + flavor comments) + ;; figure out version numbers if not already discovered + (and (or (not major) (not minor)) + (string-match "\\([0-9]+\\).\\([0-9]+\\)" emacs-version) + (setq major (string-to-int (substring emacs-version + (match-beginning 1) + (match-end 1))) + minor (string-to-int (substring emacs-version + (match-beginning 2) + (match-end 2))))) + (if (not (and major minor)) + (error "Cannot figure out the major and minor version numbers.")) + ;; calculate the major version + (cond + ((= major 18) (setq major 'v18)) ;Emacs 18 + ((= major 4) (setq major 'v18)) ;Epoch 4 + ((= major 19) (setq major 'v19 ;Emacs 19 + flavor (if (or (string-match "Lucid" emacs-version) + (string-match "XEmacs" emacs-version)) + 'XEmacs 'FSF))) + ((= major 20) (setq major 'v20 ;XEmacs 20 + flavor 'XEmacs)) + ;; I don't know + (t (error "Cannot recognize major version number: %s" major))) + ;; All XEmacs 19's (formerly Lucid) use 8-bit modify-syntax-entry + ;; flags, as do all patched (obsolete) Emacs 19, Emacs 18, + ;; Epoch 4's. Only vanilla Emacs 19 uses 1-bit flag. Lets be + ;; as smart as we can about figuring this out. + (if (or (eq major 'v20) (eq major 'v19)) + (let ((table (copy-syntax-table))) + (modify-syntax-entry ?a ". 12345678" table) + (cond + ;; XEmacs pre 20 and Emacs pre 19.30 use vectors for syntax tables. + ((vectorp table) + (if (= (logand (lsh (aref table ?a) -16) 255) 255) + (setq comments '8-bit) + (setq comments '1-bit))) + ;; XEmacs 20 is known to be 8-bit + ((eq flavor 'XEmacs) (setq comments '8-bit)) + ;; Emacs 19.30 and beyond are known to be 1-bit + ((eq flavor 'FSF) (setq comments '1-bit)) + ;; Don't know what this is + (t (error "Couldn't figure out syntax table format.")) + )) + ;; Emacs 18 has no support for dual comments + (setq comments 'no-dual-comments)) + ;; lets do some minimal sanity checking. + (if (or + ;; Lemacs before 19.6 had bugs + (and (eq major 'v19) (eq flavor 'XEmacs) (< minor 6)) + ;; Emacs 19 before 19.21 has known bugs + (and (eq major 'v19) (eq flavor 'FSF) (< minor 21)) + ) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "The version of Emacs that you are running, %s, +has known bugs in its syntax parsing routines which will affect the +performance of verilog-mode. You should strongly consider upgrading to the +latest available version. verilog-mode may continue to work, after a +fashion, but strange indentation errors could be encountered." + emacs-version)))) + ;; Emacs 18, with no patch is not too good + (if (and (eq major 'v18) (eq comments 'no-dual-comments)) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "The version of Emacs 18 you are running, %s, +has known deficiencies in its ability to handle the dual verilog +(and C++) comments, (e.g. the // and /* */ comments). This will +not be much of a problem for you if you only use the /* */ comments, +but you really should strongly consider upgrading to one of the latest +Emacs 19's. In Emacs 18, you may also experience performance degradations. +Emacs 19 has some new built-in routines which will speed things up for you. +Because of these inherent problems, verilog-mode is not supported +on emacs-18." + emacs-version)))) + ;; Emacs 18 with the syntax patches are no longer supported + (if (and (eq major 'v18) (not (eq comments 'no-dual-comments))) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "You are running a syntax patched Emacs 18 variant. While this should +work for you, you may want to consider upgrading to Emacs 19. +The syntax patches are no longer supported either for verilog-mode.")))) + (list major comments)) + "A list of features extant in the Emacs you are using. +There are many flavors of Emacs out there, each with different +features supporting those needed by verilog-mode. Here's the current +supported list, along with the values for this variable: + + Vanilla Emacs 18/Epoch 4: (v18 no-dual-comments) + Emacs 18/Epoch 4 (patch2): (v18 8-bit) + XEmacs (formerly Lucid) 19: (v19 8-bit) + Emacs 19: (v19 1-bit).") + +(defconst verilog-comment-start-regexp "//\\|/\\*" + "Dual comment value for `comment-start-regexp'.") + +(defun verilog-populate-syntax-table (table) + ;; Populate the syntax TABLE + ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS! + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?% "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?& "." table) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?\' "." table) +) + +(defun verilog-setup-dual-comments (table) + ;; Set up TABLE to handle block and line style comments + (cond + ((memq '8-bit verilog-emacs-features) + ;; XEmacs (formerly Lucid) has the best implementation + (modify-syntax-entry ?/ ". 1456" table) + (modify-syntax-entry ?* ". 23" table) + (modify-syntax-entry ?\n "> b" table) + ;; Give CR the same syntax as newline, for selective-display + (modify-syntax-entry ?\^m "> b" table)) + ((memq '1-bit verilog-emacs-features) + ;; Emacs 19 does things differently, but we can work with it + (modify-syntax-entry ?/ ". 124b" table) + (modify-syntax-entry ?* ". 23" table) + (modify-syntax-entry ?\n "> b" table) + ;; Give CR the same syntax as newline, for selective-display + (modify-syntax-entry ?\^m "> b" table)) + )) + +(defvar verilog-mode-syntax-table nil + "Syntax table used in verilog-mode buffers.") +(if verilog-mode-syntax-table + () + (setq verilog-mode-syntax-table (make-syntax-table)) + (verilog-populate-syntax-table verilog-mode-syntax-table) + ;; add extra comment syntax + (verilog-setup-dual-comments verilog-mode-syntax-table) + ) +;;; +;;; Macros +;;; + +(defsubst verilog-re-search-forward (REGEXP BOUND NOERROR) + "Like re-search-forward, but skips over matches in comments or strings" + (set-match-data '(nil nil)) + (while (and + (re-search-forward REGEXP BOUND NOERROR) + (and (verilog-skip-forward-comment-or-string) + (progn + (store-match-data '(nil nil)) + (if BOUND + (< (point) BOUND) + t) + ) + ) + ) + ) + (match-end 0)) + +(defsubst verilog-re-search-backward (REGEXP BOUND NOERROR) + "Like re-search-backward, but skips over matches in comments or strings" + (set-match-data '(nil nil)) + (while (and + (re-search-backward REGEXP BOUND NOERROR) + (verilog-skip-backward-comment-or-string) + (not (set-match-data '(nil nil)))) + ()) + (match-end 0)) + +(defsubst verilog-get-beg-of-line (&optional arg) + (save-excursion + (beginning-of-line arg) + (point))) + +(defsubst verilog-get-end-of-line (&optional arg) + (save-excursion + (end-of-line arg) + (point))) + +(defun verilog-declaration-end () + (search-forward ";")) + +(defun electric-verilog-backward-sexp () + "Move backward over a sexp" + (interactive) + ;; before that see if we are in a comment + (verilog-backward-sexp) +) +(defun electric-verilog-forward-sexp () + "Move backward over a sexp" + (interactive) + ;; before that see if we are in a comment + (verilog-forward-sexp) +) + +(defun verilog-backward-sexp () + (let ((reg) + (elsec 1) + (found nil) + ) + (if (not (looking-at "\\<")) + (forward-word -1)) + (cond + ((verilog-skip-backward-comment-or-string) + ) + ((looking-at "\\") + (setq reg (concat + verilog-end-block-re + "\\|\\(\\\\)" + "\\|\\(\\\\)" + )) + (while (and (not found) + (verilog-re-search-backward reg nil 'move)) + (cond + ((match-end 1) ; endblock + ; try to leap back to matching outward block by striding across + ; indent level changing tokens then immediately + ; previous line governs indentation. + (verilog-leap-to-head) + ) + ((match-end 2) ; else, we're in deep + (setq elsec (1+ elsec)) + ) + ((match-end 3) ; found it + (setq elsec (1- elsec)) + (if (= 0 elsec) + ;; Now previous line describes syntax + (setq found 't) + )) + ) + ) + ) + ((looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (verilog-leap-to-head) + ) + ((looking-at "\\(endmodule\\>\\)\\|\\(\\\\)") + (cond + ((match-end 1) + (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) + ((match-end 2) + (verilog-re-search-backward "\\" nil 'move)) + (t + (backward-sexp 1)))) + (t + (backward-sexp)) + ) ;; cond + ) + ) +(defun verilog-forward-sexp () + (let ((reg) + (st (point))) + (if (not (looking-at "\\<")) + (forward-word -1)) + (cond + ((verilog-skip-forward-comment-or-string) + (verilog-forward-syntactic-ws) + ) + ((looking-at verilog-beg-block-re-1);; begin|fork|case|table|specify + (cond + ((match-end 1) ; end + ;; Search forward for matching begin + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 2) ; endcase + ;; Search forward for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search forward for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search forward for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search forward for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search forward for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search forward for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (if (forward-word 1) + (catch 'skip + (let ((nest 1)) + (while (verilog-re-search-forward reg nil 'move) + (cond + ((match-end 2) ; end + (setq nest (1- nest)) + (if (= 0 nest) + (throw 'skip 1))) + ((match-end 1) ; begin + (setq nest (1+ nest))))) + ) + ) + ) + ) + ((looking-at "\\(\\<\\(macro\\)?module\\>\\)\\|\\(\\\\)") + (cond + ((match-end 1) + (verilog-re-search-forward "\\" nil 'move)) + ((match-end 2) + (verilog-re-search-forward "\\" nil 'move)) + (t + (goto-char st) + (if (= (following-char) ?\) ) + (forward-char 1) + (forward-sexp 1))))) + (t + (goto-char st) + (if (= (following-char) ?\) ) + (forward-char 1) + (forward-sexp 1))) + ) ;; cond + ) + ) + + +(defun verilog-declaration-beg () + (verilog-re-search-backward verilog-declaration-re (bobp) t)) + +(defsubst verilog-within-string () + (save-excursion + (nth 3 (parse-partial-sexp (verilog-get-beg-of-line) (point))))) + + +;;;###autoload +(defun verilog-mode () +"Major mode for editing Verilog code. \\ +NEWLINE, TAB indents for Verilog code. +Delete converts tabs to spaces as it moves back. +Supports highlighting. + +Variables controlling indentation/edit style: + + verilog-indent-level (default 3) + Indentation of Verilog statements with respect to containing block. + verilog-cexp-indent (default 1) + Indentation of Verilog statements broken across lines. + verilog-case-indent (default 2) + Indentation for case statements. + verilog-auto-newline (default nil) + Non-nil means automatically newline after simcolons and the punctation mark + after an end. + verilog-auto-indent-on-newline (default t) + Non-nil means automatically indent line after newline + verilog-tab-always-indent (default t) + Non-nil means TAB in Verilog mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + verilog-indent-begin-after-if (default t) + Non-nil means to indent begin statements following a preceeding + if, else, while, for and repeat statements, if any. otherwise, + the begin is lined up with the preceeding token. If t, you get: + if (a) + begin + otherwise you get: + if (a) + begin + verilog-auto-endcomments (default t) + Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. + The type and name of the object will be set between the braces. + verilog-auto-lineup (default `(all)) + List of contexts where auto lineup of :'s or ='s should be done. + +Turning on Verilog mode calls the value of the variable verilog-mode-hook with +no args, if that value is non-nil. +Other useful functions are: +\\[verilog-complete-word]\t-complete word with appropriate possibilities (functions, verilog keywords...) +\\[verilog-comment-area]\t- Put marked area in a comment, fixing nested comments. +\\[verilog-uncomment-area]\t- Uncomment an area commented with \ +\\[verilog-comment-area]. +\\[verilog-insert-block]\t- insert begin ... end; +\\[verilog-star-comment]\t- insert /* ... */ +\\[verilog-mark-defun]\t- Mark function. +\\[verilog-beg-of-defun]\t- Move to beginning of current function. +\\[verilog-end-of-defun]\t- Move to end of current function. +\\[verilog-label-be]\t- Label matching begin ... end, fork ... join and case ... endcase statements; +" + (interactive) + (kill-all-local-variables) + (use-local-map verilog-mode-map) + (setq major-mode 'verilog-mode) + (setq mode-name "Verilog") + (setq local-abbrev-table verilog-mode-abbrev-table) + (set-syntax-table verilog-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'verilog-indent-line) + (setq comment-indent-function 'verilog-indent-comment) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments nil) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (make-local-variable 'comment-multi-line) + (make-local-variable 'comment-start-skip) + (setq comment-start "// " + comment-end "" + comment-start-skip "/\\*+ *\\|// *" + comment-multi-line nil) + ;; Imenu support + (make-local-variable 'imenu-generic-expression) + (setq imenu-generic-expression verilog-imenu-generic-expression) + ;; Font lock support + (make-local-variable 'font-lock-keywords) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (setq verilog-font-lock-keywords verilog-font-lock-keywords-after-1930 ) + (cond ((> emacs-minor-version 29) + (setq verilog-font-lock-keywords verilog-font-lock-keywords-after-1930 )) + ('t + (setq verilog-font-lock-keywords verilog-font-lock-keywords-before-1930 )) + )) + (setq font-lock-keywords verilog-font-lock-keywords) + (run-hooks 'verilog-mode-hook)) + + +;;; +;;; Electric functions +;;; +(defun electric-verilog-terminate-line (&optional arg) + "Terminate line and indent next line." + (interactive) + ;; before that see if we are in a comment + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 7 state) ; Inside // comment + (if (eolp) + (progn + (delete-horizontal-space) + (newline)) + (progn + (newline) + (insert-string "// ") + (beginning-of-line) + )) + (verilog-indent-line) + ) + ((nth 4 state) ; Inside any comment (hence /**/) + (newline) + (beginning-of-line) + + (verilog-indent-comment t) + (insert-string "* ") + ) + ((eolp) + ;; First, check if current line should be indented + (if (save-excursion + (delete-horizontal-space) + (beginning-of-line) + (skip-chars-forward " \t") + (if (looking-at verilog-autoindent-lines-re) + (let ((indent-str (verilog-indent-line))) + ;; Maybe we should set some endcomments + (if verilog-auto-endcomments + (verilog-set-auto-endcomments indent-str arg)) + (end-of-line) + (delete-horizontal-space) + (if arg + () + (newline)) + nil) + (progn + (end-of-line) + (delete-horizontal-space) + (newline)))) + (newline) + (forward-line 1)) + ;; Indent next line + (if verilog-auto-indent-on-newline + (verilog-indent-line)) + ) + (t + (newline) + ) + ) + ) + ) + +(defun electric-verilog-semi () + "Insert `;' character and reindent the line." + (interactive) + (insert last-command-char) + (save-excursion + (beginning-of-line) + (verilog-indent-line)) + (if (and verilog-auto-newline + (= 0 (verilog-parenthesis-depth))) + (electric-verilog-terminate-line))) + +(defun electric-verilog-colon () + "Insert `:' and do all indentions except line indent on this line." + (interactive) + (insert last-command-char) + ;; Do nothing if within string. + (if (or + (verilog-within-string) + (not (verilog-in-case-region-p))) + () + (save-excursion + (let ((p (point)) + (lim (progn (verilog-beg-of-statement) (point)))) + (goto-char p) + (verilog-backward-case-item lim) + (verilog-indent-line))) +;; (let ((verilog-tab-always-indent nil)) +;; (verilog-indent-line)) + ) + ) + +(defun electric-verilog-equal () + "Insert `=', and do indention if within block." + (interactive) + (insert last-command-char) +;; Could auto line up expressions, but not yet +;; (if (eq (car (verilog-calculate-indent)) 'block) +;; (let ((verilog-tab-always-indent nil)) +;; (verilog-indent-command))) +) + + +(defun electric-verilog-tick () + "Insert back-tick, and indent to coulmn 0 if this is a CPP directive." + (interactive) + (insert last-command-char) + (if (save-excursion (beginning-of-line) (looking-at "^[ \t]*\`\\(\\\\|\\\\\|\\\\|\\\\)")) + (save-excursion (beginning-of-line) + (delete-horizontal-space)))) + +(defun electric-verilog-tab () + "Function called when TAB is pressed in Verilog mode." + (interactive) + ;; If verilog-tab-always-indent, indent the beginning of the line. + (if verilog-tab-always-indent + (let* ((boi-point (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (let (type state ) + (setq type (verilog-indent-line)) + (setq state (car type)) + (cond + ((eq state 'block) + (if (looking-at verilog-behavorial-block-beg-re ) + (error (concat "The reserved word \"" + (buffer-substring (match-beginning 0) (match-end 0)) + "\" must be at the behavorial level!")))) + )) + (back-to-indentation) + (point)))) + (if (< (point) boi-point) + (back-to-indentation))) + (progn (insert "\t")) + ) + ) + + + +;;; +;;; Interactive functions +;;; +(defun verilog-insert-block () + "Insert Verilog begin ... end; block in the code with right indentation." + (interactive) + (verilog-indent-line) + (insert "begin") + (electric-verilog-terminate-line) + (save-excursion + (electric-verilog-terminate-line) + (insert "end") + (beginning-of-line) + (verilog-indent-line))) + +(defun verilog-star-comment () + "Insert Verilog star comment at point." + (interactive) + (verilog-indent-line) + (insert "/*") + (save-excursion + (newline) + (insert " */")) + (newline) + (insert " * ")) + +(defun verilog-mark-defun () + "Mark the current verilog function (or procedure). +This puts the mark at the end, and point at the beginning." + (interactive) + (push-mark (point)) + (verilog-end-of-defun) + (push-mark (point)) + (verilog-beg-of-defun) + (if (fboundp 'zmacs-activate-region) + (zmacs-activate-region))) + +(defun verilog-comment-area (start end) + "Put the region into a Verilog comment. +The comments that are in this area are \"deformed\": +`*)' becomes `!(*' and `}' becomes `!{'. +These deformed comments are returned to normal if you use +\\[verilog-uncomment-area] to undo the commenting. + +The commented area starts with `verilog-exclude-str-start', and ends with +`verilog-include-str-end'. But if you change these variables, +\\[verilog-uncomment-area] won't recognize the comments." + (interactive "r") + (save-excursion + ;; Insert start and endcomments + (goto-char end) + (if (and (save-excursion (skip-chars-forward " \t") (eolp)) + (not (save-excursion (skip-chars-backward " \t") (bolp)))) + (forward-line 1) + (beginning-of-line)) + (insert verilog-exclude-str-end) + (setq end (point)) + (newline) + (goto-char start) + (beginning-of-line) + (insert verilog-exclude-str-start) + (newline) + ;; Replace end-comments within commented area + (goto-char end) + (save-excursion + (while (re-search-backward "\\*/" start t) + (replace-match "!/*" t t))) + ) +) + +(defun verilog-uncomment-area () + "Uncomment a commented area; change deformed comments back to normal. +This command does nothing if the pointer is not in a commented +area. See also `verilog-comment-area'." + (interactive) + (save-excursion + (let ((start (point)) + (end (point))) + ;; Find the boundaries of the comment + (save-excursion + (setq start (progn (search-backward verilog-exclude-str-start nil t) + (point))) + (setq end (progn (search-forward verilog-exclude-str-end nil t) + (point)))) + ;; Check if we're really inside a comment + (if (or (equal start (point)) (<= end (point))) + (message "Not standing within commented area.") + (progn + ;; Remove endcomment + (goto-char end) + (beginning-of-line) + (let ((pos (point))) + (end-of-line) + (delete-region pos (1+ (point)))) + ;; Change comments back to normal + (save-excursion + (while (re-search-backward "!/\\*" start t) + (replace-match "*/" t t))) + ;; Remove startcomment + (goto-char start) + (beginning-of-line) + (let ((pos (point))) + (end-of-line) + (delete-region pos (1+ (point))))))))) + +(defun verilog-beg-of-defun () + "Move backward to the beginning of the current function or procedure." + (interactive) + (verilog-re-search-backward verilog-defun-re nil 'move) + ) +(defun verilog-end-of-defun () + (interactive) + (verilog-re-search-forward verilog-end-defun-re nil 'move) + ) + +(defun verilog-label-be (&optional arg) + "Label matching begin ... end, fork ... join and case ... endcase statements in this module; +With argument, first kill any existing labels." + (interactive) + (let ((cnt 0) + (oldpos (point)) + (b (progn + (verilog-beg-of-defun) + (point-marker))) + (e (progn + (verilog-end-of-defun) + (point-marker))) + ) + (goto-char (marker-position b)) + (if (> (- e b) 200) + (message "Relabeling module...")) + (while (and + (> (marker-position e) (point)) + (verilog-re-search-forward + (concat + "\\" + "\\|\\(`endif\\)\\|\\(`else\\)") + nil 'move)) + (goto-char (match-beginning 0)) + (let ((indent-str (verilog-indent-line))) + (verilog-set-auto-endcomments indent-str 't) + (end-of-line) + (delete-horizontal-space) + ) + (setq cnt (1+ cnt)) + (if (= 9 (% cnt 10)) + (message "%d..." cnt)) + ) + (goto-char oldpos) + (if (or + (> (- e b) 200) + (> cnt 20)) + (message "%d lines autocommented" cnt)) + ) + ) + +(defun verilog-beg-of-statement () + "Move backward to beginning of statement" + (interactive) + (while (save-excursion + (and + (not (looking-at verilog-complete-reg)) + (skip-chars-backward " \t") + (not (or (bolp) (= (preceding-char) ?\;))) + ) + ) + (skip-chars-backward " \t") + (verilog-backward-token)) + (let ((last (point))) + (while (progn + (setq last (point)) + (and (not (looking-at verilog-complete-reg)) + (verilog-continued-line)))) + (goto-char last) + (verilog-forward-syntactic-ws) + ) + ) +(defun verilog-end-of-statement () + "Move forward to end of current statement." + (interactive) + (let ((nest 0) pos) + (if (not (looking-at "[ \t\n]")) (forward-sexp -1)) + (or (looking-at verilog-beg-block-re) + ;; Skip to end of statement + (setq pos (catch 'found + (while t + (forward-sexp 1) + (verilog-skip-forward-comment-or-string) + (cond ((looking-at "[ \t]*;") + (skip-chars-forward "^;") + (forward-char 1) + (throw 'found (point))) + ((save-excursion + (forward-sexp -1) + (looking-at verilog-beg-block-re)) + (goto-char (match-beginning 0)) + (throw 'found nil)) + ((eobp) + (throw 'found (point)))))))) + (if (not pos) + ;; Skip a whole block + (catch 'found + (while t + (verilog-re-search-forward verilog-end-statement-re nil 'move) + (setq nest (if (match-end 1) + (1+ nest) + (1- nest))) + (cond ((eobp) + (throw 'found (point))) + ((= 0 nest) + (throw 'found (verilog-end-of-statement)))))) + pos))) +(defun verilog-in-case-region-p () + "Return TRUE if in a case region: more specifically, point @ in the line foo : @ begin" + (interactive) + (save-excursion + (if (and + (progn (verilog-forward-syntactic-ws) + (looking-at "\\")) + (progn (verilog-backward-syntactic-ws) + (= (preceding-char) ?\:))) + (catch 'found + (let ((nest 1)) + (while t + (verilog-re-search-backward "\\(\\\\)\\|\\(\\[^:]\\)\\|\\(\\\\)\\>" nil 'move) + (cond + ((match-end 3) + (setq nest (1+ nest))) + ((match-end 2) + (if (= nest 1) + (throw 'found 1)) + (setq nest (1- nest)) + ) + ( t + (throw 'found (= nest 0))) + ) + ) + ) + ) + nil) + ) + ) +(defun verilog-backward-case-item (lim) + "Skip backward to nearest enclosing case item" + (interactive) + (let ( + (str 'nil) + (lim1 (progn + (save-excursion (verilog-re-search-backward verilog-endcomment-reason-re lim 'move) + (point))))) + ;; Try to find the real : + (if (save-excursion (search-backward ":" lim1 t)) + (let ((colon 0) + b e ) + (while (and (< colon 1) + (verilog-re-search-backward "\\(\\[\\)\\|\\(\\]\\)\\|\\(:\\)" lim1 'move)) + (cond + ((match-end 1) ;; [ + (setq colon (1+ colon)) + (if (>= colon 0) + (error "unbalanced ["))) + ((match-end 2) ;; ] + (setq colon (1- colon))) + + ((match-end 3) ;; : + (setq colon (1+ colon))) + + ) + ) + ;; Skip back to begining of case item + (skip-chars-backward "\t ") + (verilog-skip-backward-comment-or-string) + (setq e (point)) + (setq b (progn + (if (verilog-re-search-backward "\\<\\(case[zx]?\\)\\>\\|;\\|\\" nil 'move) + (progn + (cond + ((match-end 1) + (goto-char (match-end 1)) + (verilog-forward-ws&directives) + (if (looking-at "(") + (progn + (forward-sexp) + (verilog-forward-ws&directives) + )) + (point)) + (t + (goto-char (match-end 0)) + (verilog-forward-ws&directives) + (point)) + )) + (error "Malformed case item") + ) + ) + ) + (setq str (buffer-substring b e)) + (if (setq e (string-match "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) + (setq str (concat (substring str 0 e) "..."))) + str) + 'nil) + ) + ) + + +;;; +;;; Other functions +;;; + +(defun kill-existing-comment () + "kill autocomment on this line" + (save-excursion + (let* ( + (e (progn + (end-of-line) + (point))) + (b (progn + (beginning-of-line) + (search-forward "//" e t)))) + (if b + (delete-region (- b 2) e)) + ) + ) + ) + +(defun verilog-set-auto-endcomments (indent-str kill-existing-comment) + "Insert `// case: 7 ' or `// NAME ' on this line if appropriate. +Insert `// case expr ' if this line ends a case block. +Insert `// ifdef FOO ' if this line ends code conditional on FOO. +Insert `// NAME ' if this line ends a module or primitive named NAME." + (save-excursion + (cond + (; Comment close preprocessor directives + (and + (looking-at "\\(`endif\\)\\|\\(`else\\)") + (or kill-existing-comment + (not (save-excursion + (end-of-line) + (search-backward "//" (verilog-get-beg-of-line) t))))) + (let ( (reg "\\(`else\\)\\|\\(`ifdef\\)\\|\\(`endif\\)") + (nest 1) + b e + (else (if (match-end 2) + 1 + 0)) + ) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (save-excursion + (backward-sexp 1) + (while (and (/= nest 0) + (verilog-re-search-backward reg nil 'move)) + (cond + ((match-end 1) ; `else + (if (= nest 1) + (setq else 1))) + ((match-end 2) ; `ifdef + (setq nest (1- nest))) + ((match-end 3) ; `endif + (setq nest (1+ nest))) + )) + (if (match-end 0) + (setq b (progn + (skip-chars-forward "^ \t") + (verilog-forward-syntactic-ws) + (point)) + e (progn + (skip-chars-forward "a-zA-Z0-9_") + (point) + )))) + (if b + (if (> (- (point) b) verilog-minimum-comment-distance) + (insert (concat (if + (= else 0) + " // ifdef " + " // !ifdef ") + (buffer-substring b e)))) + (progn + (insert " // unmatched `endif") + (ding 't)) + ))) + + (; Comment close case/function/task/module and named block + (and (looking-at "\\\\)\\|\\(\\\\)\\|\\(\\\\)") + (cond + (;- This is a case block; search back for the start of this case + (match-end 1) + + (let ((err 't) + (str "UNMATCHED!!")) + (save-excursion + (verilog-leap-to-head) + (if (match-end 0) + (progn + (goto-char (match-end 1)) + (setq str (concat (buffer-substring (match-beginning 1) (match-end 1)) + (verilog-get-expr))) + (setq err nil)))) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (insert (concat " // " str )) + (if err (ding 't)) + )) + + (;- This is a begin..end block + (match-end 2) + (let ((str " // UNMATCHED !!") + (err 't) + (here (point)) + there + cntx + ) + (save-excursion + (verilog-leap-to-head) + (setq there (point)) + (if (not (match-end 0)) + (progn + (goto-char here) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (insert str) + (ding 't) + ) + (let ( sp + (lim (save-excursion (verilog-beg-of-defun) (point))) + (here (point)) + ) + (cond + (;-- handle named block differently + (looking-at verilog-named-block-re) + (search-forward ":") + (setq there (point)) + (setq str (verilog-get-expr)) + (setq err nil) + (setq str (concat " // block: " str ))) + + ((verilog-in-case-region-p) ;-- handle case item differently + (goto-char here) + (setq str (verilog-backward-case-item lim)) + (setq there (point)) + (setq err nil) + (setq str (concat " // case: " str )) + ) + (;- try to find "reason" for this begin + (cond + (; + (eq here (progn (verilog-beg-of-statement) (point))) + (setq err nil) + (setq str "")) + ((looking-at verilog-endcomment-reason-re) + (setq there (match-end 0)) + (setq cntx (concat + (buffer-substring (match-beginning 0) (match-end 0)) " ")) + (cond + (; + (match-end 2) + (setq err nil) + (save-excursion + (goto-char sp) + (if (and (verilog-continued-line) + (looking-at "\\\\|\\\\|\\")) + (progn + (goto-char (match-end 0)) + (setq there (point)) + (setq str + (concat " // " + (buffer-substring (match-beginning 0) (match-end 0)) " " + (verilog-get-expr)))) + (setq str "") + ) + ) + ) + (;- else + (match-end 4) + (let ((nest 0) + ( reg "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") + ) + (catch 'skip + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; begin + (setq nest (1- nest))) + ((match-end 2) ; end + (setq nest (1+ nest))) + ((match-end 3) + (if (= 0 nest) + (progn + (goto-char (match-end 0)) + (setq there (point)) + (setq err nil) + (setq str (verilog-get-expr)) + (setq str (concat " // else: !if" str )) + (throw 'skip 1)) + ))) + ) + ) + ) + ) + (;- task/function/initial et cetera + t + (match-end 0) + (goto-char (match-end 0)) + (setq there (point)) + (setq err nil) + (setq str (verilog-get-expr)) + (setq str (concat " // " cntx str ))) + + (;-- otherwise... + (setq str " // auto-endcomment confused ") + ) + ) + ) + ((and + (verilog-in-case-region-p) ;-- handle case item differently + (progn + (setq there (point)) + (goto-char here) + (setq str (verilog-backward-case-item lim)))) + (setq err nil) + (setq str (concat " // case: " str )) + ) + ) + ) + ) + ) + (goto-char here) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (if (or err + (> (- here there) verilog-minimum-comment-distance)) + (insert str)) + (if err (ding 't)) + ) + ) + ) + ) + + + (;- this is end{function,task,module} + t + (let (string reg (width nil)) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (backward-sexp) + (cond + ((match-end 5) + (setq reg "\\(\\\\)\\|\\(\\<\\(endfunction\\|task\\|\\(macro\\)?module\\|primitive\\)\\>\\)") + (setq width "\\([ \t]*\\[[^]]*\\]\\)?") + ) + ((match-end 6) + (setq reg "\\(\\\\)\\|\\(\\<\\(endtask\\|function\\|\\(macro\\)?module\\|primitive\\)\\>\\)")) + ((match-end 7) + (setq reg "\\(\\<\\(macro\\)?module\\>\\)\\|\\")) + ((match-end 8) + (setq reg "\\(\\\\)\\|\\(\\<\\(endprimitive\\|function\\|task\\|\\(macro\\)?module\\)\\>\\)")) + ) + (let (b e) + (save-excursion + (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) + (setq b (progn + (skip-chars-forward "^ \t") + (verilog-forward-ws&directives) + (if (and width (looking-at width)) + (progn + (goto-char (match-end 0)) + (verilog-forward-ws&directives) + )) + (point)) + e (progn + (skip-chars-forward "a-zA-Z0-9_") + (point))) + (setq string (buffer-substring b e))) + (t + (ding 't) + (setq string "unmactched end(function|task|module|primitive)"))))) + (end-of-line) + (insert (concat " // " string ))) + ) + ) + ) + ) + ) + ) + ) + ) + ) + +(defun verilog-get-expr() + "Grab expression at point, e.g, case ( a | b & (c ^d))" + (let* ((b (progn + (verilog-forward-syntactic-ws) + (skip-chars-forward " \t") + (point))) + (e (let ((par 1)) + (cond + ((looking-at "(") + (forward-char 1) + (while (and (/= par 0) + (verilog-re-search-forward "\\((\\)\\|\\()\\)" nil 'move)) + (cond + ((match-end 1) + (setq par (1+ par))) + ((match-end 2) + (setq par (1- par))))) + (point)) + ((looking-at "\\[") + (forward-char 1) + (while (and (/= par 0) + (verilog-re-search-forward "\\(\\[\\)\\|\\(\\]\\)" nil 'move)) + (cond + ((match-end 1) + (setq par (1+ par))) + ((match-end 2) + (setq par (1- par))))) + (verilog-forward-syntactic-ws) + (skip-chars-forward "^ \t\n") + (point)) + ((looking-at "/[/\\*]") + b) + ('t + (skip-chars-forward "^: \t\n") + (point) + )))) + (str (buffer-substring b e))) + (if (setq e (string-match "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) + (setq str (concat (substring str 0 e) "..."))) + str) + ) + + +;;; +;;; Indentation +;;; +(defconst verilog-indent-alist + '((block . (+ ind verilog-indent-level)) + (case . (+ ind verilog-case-indent)) + (cparenexp . (+ ind verilog-indent-level)) + (cexp . (+ ind verilog-indent-level)) + (defun . verilog-indent-level) + (declaration . verilog-indent-level) + (tf . verilog-indent-level) + (behavorial . verilog-indent-level) + (statement . ind) + (cpp . 0) + (comment . (verilog-indent-comment)) + (unknown . 3) + (string . 0))) + +(defun verilog-calculate-indent () + "Calculate the indent of the current Verilog line, through examination +of previous lines. Once a line is found that is definitive as to the +type of the current line, return that lines' indent level and it's +type. Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." + (save-excursion + (let* ((starting_position (point)) + (par 0) + (begin (looking-at "[ \t]*begin\\>")) + (type (catch 'nesting + ;; Keep working backwards until we can figure out + ;; what type of statement this is. + ;; Basically we need to figure out + ;; 1) if this is a continuation of the previous line; + ;; 2) are we in a block scope (begin..end) + + ;; if we are in a comment, done. + (if (verilog-in-star-comment-p) (throw 'nesting 'comment)) + + ;; if we are in a parenthesized list, done. + (if (verilog-in-paren) (progn (setq par 1) (throw 'nesting 'block))) + + ;; See if we are continuing a previous line + (while t + ;; trap out if we crawl off the top of the buffer + (if (bobp) (throw 'nesting 'cpp)) + + (if (verilog-continued-line) + (let ((sp (point))) + (if (and + (not (looking-at verilog-complete-reg)) + (verilog-continued-line)) + (progn (goto-char sp) + (throw 'nesting 'cexp)) + (goto-char sp)) + (if (and begin + (not verilog-indent-begin-after-if) + (looking-at verilog-no-indent-begin-re)) + (throw 'nesting 'statement) + (throw 'nesting 'cexp))) + + ;; not a continued line + (goto-char starting_position)) + + (if (looking-at "\\") + ;; search back for governing if, striding across begin..end pairs + ;; appropriately + (let ((reg (concat + verilog-end-block-re + "\\|\\(\\\\)" + "\\|\\(\\\\)" + )) + (elsec 1) + ) + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; endblock + ; try to leap back to matching outward block by striding across + ; indent level changing tokens then immediately + ; previous line governs indentation. + (let ((reg)(nest 1)) + (looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (cond + ((match-end 1) ; end + ;; Search back for matching begin + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 2) ; endcase + ;; Search back for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search back for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search back for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search back for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search back for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search back for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (catch 'skip + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; begin + (setq nest (1- nest)) + (if (= 0 nest) + (throw 'skip 1))) + ((match-end 2) ; end + (setq nest (1+ nest))))) + ) + ) + ) + ((match-end 2) ; else, we're in deep + (setq elsec (1+ elsec)) + ) + ((match-end 3) ; found it + (setq elsec (1- elsec)) + (if (= 0 elsec) + ;; Now previous line describes syntax + (throw 'nesting 'statement) + ))) + ) + ) + ) + (while (verilog-re-search-backward verilog-indent-reg nil 'move) + (cond + ((match-end 1) ; beg-block + (looking-at verilog-beg-block-re-1) + (cond + ((match-end 2) (throw 'nesting 'case)) + (t (throw 'nesting 'block)))) + + ((match-end 2) ;; end-block + (verilog-leap-to-head) + (if (verilog-in-case-region-p) + (progn + (verilog-leap-to-case-head) + (if (looking-at verilog-case-re) + (throw 'nesting 'case)) + ))) + + ((or (match-end 3) ;; module.. primitive + (match-end 5)) ;; endtask.. + (throw 'nesting 'defun)) + + ((match-end 4) ;; endmodule + (throw 'nesting 'cpp)) + + ((match-end 6) ;; function/task + (throw 'nesting 'behavorial)) + + ((bobp) + (throw 'nesting 'cpp)) + ) + ) + ) + ) + ) + ) + ;; Return type of block and indent level. + (if (not type) + (setq type 'cpp)) + (if (> par 0) ; Unclosed Parenthesis + (list 'cparenexp par) + (if (eq type 'case) + (list type (verilog-case-indent-level)) + (list type (verilog-indent-level))))))) +(defun verilog-leap-to-case-head () "" + (let ((nest 1)) + (while (/= 0 nest) + (verilog-re-search-backward "\\(\\[^:]\\)\\|\\(\\\\)" nil 'move) + (cond + ((match-end 1) + (setq nest (1- nest))) + ((match-end 2) + (setq nest (1+ nest))) + ((bobp) + (ding 't) + (setq nest 0)) + ) + ) + ) + ) + +(defun verilog-leap-to-head () "foo" + (let (reg + snest + (nest 1)) + (if (looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (progn + (cond + ((match-end 1) ; end + ;; Search back for matching begin + (setq reg (concat "\\(\\\\)\\|\\(\\\\)\\|" + "\\(\\\\)\\|\\(\\\\)" ))) + + ((match-end 2) ; endcase + ;; Search back for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search back for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search back for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search back for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search back for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search back for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (catch 'skip + (let (sreg) + (while (verilog-re-search-backward reg nil 'move) + + (cond + ((match-end 1) ; begin + (setq nest (1- nest)) + (if (= 0 nest) + ;; Now previous line describes syntax + (throw 'skip 1)) + (if (and snest + (= snest nest)) + (setq reg sreg)) + ) + ((match-end 2) ; end + (setq nest (1+ nest)) + ) + ((match-end 3) + ;; endcase, jump to case + (setq snest nest) + (setq nest (1+ nest)) + (setq sreg reg) + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 4) + ;; join, jump to fork + (setq snest nest) + (setq nest (1+ nest)) + (setq sreg reg) + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + ) + ) + ) + ) + ) + ) + ) +(defun verilog-continued-line () + "Return true if this is a continued line. + Set point to where line starts" + (let ((continued 't)) + (if (eq 0 (forward-line -1)) + (progn + (end-of-line) + (verilog-backward-ws&directives) + (if (bobp) + (setq continued nil) + (while (and continued + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (setq continued (verilog-backward-token)) + ) ;; while + ) + ) + (setq continued nil) + ) + continued) + ) + +(defun verilog-backward-token () + "step backward token, returning true if we are now at an end of line token" + (verilog-backward-syntactic-ws) + (cond + ((bolp) + nil) + (;-- Anything ending in a ; is complete + (= (preceding-char) ?\;) + nil) +;; (;-- Anything ending in a , is deemed complete +;; (= (preceding-char) ?\,) +;; nil) + + (;-- Could be 'case (foo)' or 'always @(bar)' which is complete + (= (preceding-char) ?\)) + (progn + (backward-char) + (backward-up-list 1) + (verilog-backward-syntactic-ws) + (forward-word -1) + (not (looking-at "\\[^:]")))) + + (;-- any of begin|initial|while are complete statements; 'begin : foo' is also complete + t + (forward-word -1) + (cond + ( + (looking-at "\\(initial\\>\\)\\|\\(always\\>\\)") + t) + ( + (looking-at verilog-indent-reg) + nil) + (t + (let + ((back (point))) + (verilog-backward-syntactic-ws) + (cond + ((= (preceding-char) ?\:) + (backward-char) + (verilog-backward-syntactic-ws) + (backward-sexp) + (if (looking-at "begin") + nil + t) + ) + ((= (preceding-char) ?\#) + (backward-char) + t) + + (t + (goto-char back) + t) + ) + ) + ) + ) + ) + ) +) + +(defun verilog-backward-syntactic-ws (&optional lim) + ;; Backward skip over syntactic whitespace for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-min))) + (here lim) + bol + ) + (if (< lim (point)) + (progn + (narrow-to-region lim (point)) + (while (/= here (point)) + (setq here (point)) + (forward-comment (-(buffer-size))) + (save-excursion + (setq bol (progn (beginning-of-line) (point)))) + (search-backward "//" bol t) + ))) + ))) + +(defun verilog-forward-syntactic-ws (&optional lim) + ;; forward skip over syntactic whitespace for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-max))) + (here lim) + ) + (if (> lim (point)) + (progn + (narrow-to-region (point) lim) + (while (/= here (point)) + (setq here (point)) + (forward-comment (buffer-size)) + ))) + ))) + +(defun verilog-backward-ws&directives (&optional lim) + ;; Backward skip over syntactic whitespace and compiler directives for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-min))) + (here lim) + jump + ) + (if (< lim (point)) + (progn + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 4 state) ;; in /* */ comment + (verilog-re-search-backward "/\*" nil 'move) + ) + ((nth 7 state) ;; in // comment + (verilog-re-search-backward "//" nil 'move) + ))) + (narrow-to-region lim (point)) + (while (/= here (point)) + (setq here (point)) + (forward-comment (-(buffer-size))) + (save-excursion + (beginning-of-line) + (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)\\|\\(`include\\)") + (setq jump t) + (setq jump nil))) + (if jump + (beginning-of-line)) + ))) + ))) + +(defun verilog-forward-ws&directives (&optional lim) + ;; forward skip over syntactic whitespace and compiler directives for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-max))) + (here lim) + jump + ) + (if (> lim (point)) + (progn + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 4 state) ;; in /* */ comment + (verilog-re-search-forward "/\*" nil 'move) + ) + ((nth 7 state) ;; in // comment + (verilog-re-search-forward "//" nil 'move) + ))) + (narrow-to-region (point) lim) + (while (/= here (point)) + (setq here (point)) + (forward-comment (buffer-size)) + (save-excursion + (beginning-of-line) + (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)") + (setq jump t))) + (if jump + (beginning-of-line 2)) + ))) + ))) +(defun verilog-parenthesis-depth () + "Return non zero if in parenthetical-expression" + (save-excursion + (car (parse-partial-sexp (point-min) (point))))) + +(defun verilog-in-comment-or-string-p () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (or (nth 3 state) (nth 4 state) (nth 7 state))) ; Inside string or comment + ) + +(defun verilog-in-star-comment-p () + "Return true if in a star comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (nth 4 state)) + ) + +(defun verilog-in-paren () + "Return true if in a parenthetical expression" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (/= 0 (nth 0 state))) + ) + +(defun verilog-skip-forward-comment-or-string () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 3 state) ;Inside string + (goto-char (nth 3 state)) + t) + ((nth 7 state) ;Inside // comment + (forward-line 1) + t) + ((nth 4 state) ;Inside any comment (hence /**/) + (search-forward "*/")) + (t + nil) + ) + ) + ) + +(defun verilog-skip-backward-comment-or-string () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 3 state) ;Inside string + (search-backward "\"") + t) + ((nth 7 state) ;Inside // comment + (search-backward "//") + t) + ((nth 4 state) ;Inside /* */ comment + (search-backward "/*") + t) + (t + nil) + ) + ) + ) + +(defun verilog-skip-forward-comment-p () + "If in comment, move to end and return true" + (let (state) + (progn + (setq state + (save-excursion + (parse-partial-sexp (point-min) (point)))) + (cond + ((nth 3 state) + t) + ((nth 7 state) ;Inside // comment + (end-of-line) + (forward-char 1) + t) + ((nth 4 state) ;Inside any comment + t) + (t + nil) + ) + ) + ) + ) + +(defun verilog-indent-line-relative () + "Cheap version of indent line that only looks at + a few lines to determine indent level" + (interactive) + (let ((indent-str)) + (save-excursion + (beginning-of-line) + (if (looking-at "^[ \t]*$") + (cond ;- A blank line; No need to be too smart. + ((bobp) + (setq indent-str (list 'cpp 0))) + ((verilog-continued-line) + (let ((sp (point))) + (if (verilog-continued-line) + (progn (goto-char sp) + (setq indent-str (list 'statement (verilog-indent-level)))) + (goto-char sp) + (setq indent-str (list 'block (verilog-indent-level)))))) + (t + (setq indent-str (verilog-calculate-indent)))) + (setq indent-str (verilog-calculate-indent)) + ) + ) + (verilog-do-indent indent-str) + ) + ) +(defun verilog-indent-line () + "Indent for special part of code." + (if (looking-at verilog-directive-re) + ;; We could nicely nest `ifdef's, but... + (progn + (delete-horizontal-space) + (indent-to 0) + (list 'cpp 0)) ; Return verilog-calculate-indent data + (verilog-do-indent (verilog-calculate-indent))) + ) + +(defun verilog-do-indent (indent-str) + "" + (let ((type (car indent-str)) + (ind (car (cdr indent-str)))) + (delete-horizontal-space) + (cond + (; handle comma continued exp + (eq type 'cexp) + (let ((here (point))) + (if (progn (verilog-backward-syntactic-ws) + (= (preceding-char) ?\,)) + (let* ( fst + (column + (save-excursion + (backward-char 1) + (verilog-beg-of-statement) + (setq fst (point)) + (if (looking-at verilog-declaration-re) + (progn ;; we have multiple words + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (if (= (following-char) ?\[) + (progn + (forward-char 1) + (backward-up-list -1) + (skip-chars-forward " \t") + ) + ) + ) + (;; we have a single word + goto-char fst) + ) + (current-column) + ) + ) + ) + (goto-char here) + (beginning-of-line) + (delete-horizontal-space) + (indent-to column)) + (progn + (goto-char here) + (let ((val (eval (cdr (assoc type verilog-indent-alist))))) + ;; (verilog-comment-depth type val) + (delete-horizontal-space) + (indent-to val) + )) + ) + ) + ) + (;-- Declaration -- maybe line 'em up + (and (not (or + (eq type 'cpp) + (eq type 'comment))) + (looking-at verilog-declaration-re) + (or (memq 'all verilog-auto-lineup) + (memq 'declaration verilog-auto-lineup))) + (verilog-indent-declaration (cond ((eq type 'defun) 0) + (t ind))) + ) + (; handle inside parenthetical expressions + (eq type 'cparenexp) + (let ((column (save-excursion + (backward-up-list 1) + (forward-char 1) + (skip-chars-forward " \t") + (current-column)))) + (beginning-of-line) + (delete-horizontal-space) + (indent-to column))) + + (;-- Case -- maybe line 'em up + (and (eq type 'case) (not (looking-at "^[ \t]*$"))) + (progn + (cond + ((looking-at "\\") + (indent-to ind)) + (t + (indent-to (eval (cdr (assoc type verilog-indent-alist)))) + )))) + + (;-- Handle the ends + (looking-at verilog-end-block-re) + (if (eq type 'statement) + (indent-to (- ind verilog-indent-level)) + (indent-to ind))) + (;-- defun + (and (eq type 'defun) + (looking-at verilog-zero-indent-re)) + (indent-to 0)) + + (;-- Everything else + t + (let ((val (eval (cdr (assoc type verilog-indent-alist))))) + ;; (verilog-comment-depth type val) + (delete-horizontal-space) + (indent-to val) + )) + ) + (if (looking-at "[ \t]+$") + (skip-chars-forward " \t")) + indent-str ; Return verilog-calculate-indent data + ) +) + +(defun verilog-indent-level () + "Return the indent-level the current statement has." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (current-column))) + + +(defun verilog-case-indent-level () + "Return the indent-level the current statement has. +Do not count named blocks or case-statements." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (cond + ((looking-at verilog-named-block-re) + (current-column)) + ((and (not (looking-at verilog-case-re)) + (looking-at "[^:;]+[ \t]*:")) + (search-forward ":" nil t) + (skip-chars-forward " \t") + (current-column)) + (t + (current-column))))) + +(defun verilog-indent-comment (&optional arg) + "Indent current line as comment. +If optional arg is non-nil, just return the +column number the line should be indented to." + (let* ((stcol + (cond + ((verilog-in-star-comment-p) + (save-excursion + (re-search-backward "/\\*" nil t) + (1+(current-column)))) + ( comment-column + comment-column ) + (t + (save-excursion + (re-search-backward "//" nil t) + (current-column))) + ) + )) + (if arg + (progn + (delete-horizontal-space) + (indent-to stcol)) + stcol + ) + ) + ) + +;;; + + +(defun verilog-indent-declaration (base-ind &optional arg start end) + "Indent current lines as declaration, lining up the variable names" + (interactive) + (let ((pos (point-marker)) + (lim (save-excursion (progn (end-of-line) (point-marker)))) + ) + (if (and (not (or arg start)) (not (verilog-re-search-forward verilog-declaration-re lim t))) + () + (progn + (beginning-of-line) + (delete-horizontal-space) + (indent-to (+ base-ind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (let* ((pos2 (point-marker)) + (more 1) + here + (stpos (if start start + (save-excursion + + (goto-char pos2) + (catch 'first + (while more + (setq here (point)) + (verilog-backward-syntactic-ws) + (if (= (preceding-char) ?\;) + (backward-char)) + (verilog-beg-of-statement) + (if (bobp) + (throw 'first (point-marker))) + (if (looking-at verilog-declaration-re) + (setq more (/= (point) here)) + (throw 'first (point-marker)))) + (throw 'first (point-marker))) + ) + ) + ) + (edpos (if end + (set-marker (make-marker) end) + lim)) + ind) + (goto-char stpos) + ;; Indent lines in declaration block + (if arg + (while (<= (point) (marker-position edpos)) + (beginning-of-line) + (delete-horizontal-space) + (cond + ((looking-at "^[ \t]*$") + ()) + ((not (looking-at verilog-declaration-re)) + (indent-to arg)) + (t + (indent-to (+ arg verilog-indent-level)))) + (forward-line 1))) + + ;; Do lineup + (setq ind (verilog-get-lineup-indent stpos edpos)) + (goto-char stpos) + (if (> (- edpos stpos) 100) + (message "Lining up declarations..(please stand by)")) + (let (e) + (while (progn (setq e (marker-position edpos)) + (< (point) e)) + (if (verilog-re-search-forward verilog-declaration-re-1 e 'move) + (just-one-space)) +;; (forward-char -1)) + (save-excursion + (let ((p (point))) + (beginning-of-line) + (if (verilog-re-search-forward "\\[" p 'move) + (progn + (forward-char -1) + (just-one-space))) + )) + (delete-horizontal-space) + (indent-to ind) + (beginning-of-line) + (delete-horizontal-space) + (indent-to (+ base-ind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (forward-line 1))))) + + ;; If arg - move point + (message "") + (if arg (forward-line -1) + (goto-char (marker-position pos)))))) + +; "Return the indent level that will line up several lines within the region +;from b to e nicely. The lineup string is str." +(defun verilog-get-lineup-indent (b edpos) + (save-excursion + (let ((ind 0) e) + (goto-char b) + ;; Get rightmost position + (while (progn (setq e (marker-position edpos)) + (< (point) e)) + (if (verilog-re-search-forward verilog-declaration-re-1 e 'move) + (progn + (goto-char (match-end 0)) + (verilog-backward-syntactic-ws) + (if (> (current-column) ind) + (setq ind (current-column))) + (goto-char (match-end 0))))) + (if (> ind 0) + (1+ ind) + ;; No lineup-string found + (goto-char b) + (end-of-line) + (skip-chars-backward " \t") + (1+ (current-column)))))) + +;; A useful mode debugging aide +(defun verilog-comment-depth (type val) + "" + (save-excursion + (let + ((b (prog2 + (beginning-of-line) + (point-marker) + (end-of-line))) + (e (point-marker))) + (if (re-search-backward " /\\* \[#-\]# \[a-z\]+ \[0-9\]+ ## \\*/" b t) + (progn + (replace-match " /* -# ## */") + (end-of-line)) + (progn + (end-of-line) + (insert " /* ## ## */")))) + (backward-char 6) + (insert + (format "%s %d" type val)) + ) + ) +;;; +;;; +;;; Completion +;;; +(defvar verilog-str nil) +(defvar verilog-all nil) +(defvar verilog-pred nil) +(defvar verilog-buffer-to-use nil) +(defvar verilog-flag nil) +(defvar verilog-toggle-completions nil + "*Non-nil means \\\\[verilog-complete-word] should try all possible completions one by one. +Repeated use of \\[verilog-complete-word] will show you all of them. +Normally, when there is more than one possible completion, +it displays a list of all possible completions.") + + +(defvar verilog-type-keywords + '("buf" "bufif0" "bufif1" "cmos" "defparam" "inout" "input" + "integer" "nand" "nmos" "nor" "not" "notif0" "notif1" "or" "output" "parameter" + "pmos" "pull0" "pull1" "pullup" "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran" + "rtranif0" "rtranif1" "time" "tran" "tranif0" "tranif1" "tri" "tri0" "tri1" + "triand" "trior" "trireg" "wand" "wire" "wor" "xnor" "xor" ) + "*Keywords for types used when completing a word in a declaration or parmlist. +\(eg. integer, real, char.) The types defined within the Verilog program +will be completed runtime, and should not be added to this list.") + +(defvar verilog-defun-keywords + '("begin" "function" "task" "initial" "always" "assign" "posedge" "negedge" "endmodule") + "*Keywords to complete when standing at first word of a line in declarative scope. +\(eg. initial, always, begin, assign.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-block-keywords + '("begin" "fork" "join" "case" "end" "if" "else" "for" "while" "repeat") + "*Keywords to complete when standing at first word of a line in behavorial scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-tf-keywords + '("begin" "fork" "join" "case" "end" "endtask" "endfunction" "if" "else" "for" "while" "repeat") + "*Keywords to complete when standing at first word of a line in a task or function scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-case-keywords + '("begin" "fork" "join" "case" "end" "endcase" "if" "else" "for" "repeat") + "*Keywords to complete when standing at first word of a line in behavorial scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-separator-keywords + '("else" "then" "begin") + "*Keywords to complete when NOT standing at the first word of a statement. +\(eg. else, then.) +Variables and function names defined within the +Verilog program are completed runtime and should not be added to this list.") + +(defun verilog-string-diff (str1 str2) + "Return index of first letter where STR1 and STR2 differs." + (catch 'done + (let ((diff 0)) + (while t + (if (or (> (1+ diff) (length str1)) + (> (1+ diff) (length str2))) + (throw 'done diff)) + (or (equal (aref str1 diff) (aref str2 diff)) + (throw 'done diff)) + (setq diff (1+ diff)))))) + +;; Calculate all possible completions for functions if argument is `function', +;; completions for procedures if argument is `procedure' or both functions and +;; procedures otherwise. + +(defun verilog-func-completion (type) + ;; Build regular expression for module/task/function names + (if (string= verilog-str "") + (setq verilog-str "[a-zA-Z_]")) + (let ((verilog-str (concat (cond + ((eq type 'module) "\\<\\(module\\)\\s +") + ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") + (t "\\<\\(task\\|function\\|module\\)\\s +")) + "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) + match) + + (if (not (looking-at verilog-defun-re)) + (verilog-re-search-backward verilog-defun-re nil t)) + (forward-char 1) + + ;; Search through all reachable functions + (goto-char (point-min)) + (while (verilog-re-search-forward verilog-str (point-max) t) + (progn (setq match (buffer-substring (match-beginning 2) + (match-end 2))) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all))))) + (if (match-beginning 0) + (goto-char (match-beginning 0))))) + +(defun verilog-get-completion-decl () + ;; Macro for searching through current declaration (var, type or const) + ;; for matches of `str' and adding the occurence tp `all' + (let ((end (save-excursion (verilog-declaration-end) + (point))) + match) + ;; Traverse lines + (while (< (point) end) + (if (verilog-re-search-forward verilog-declaration-re-1 (verilog-get-end-of-line) t) + ;; Traverse current line + (while (and (verilog-re-search-forward + (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" + verilog-symbol-re) + (verilog-get-beg-of-line) t) + (not (match-end 1))) + (setq match (buffer-substring (match-beginning 0) (match-end 0))) + (if (string-match (concat "\\<" verilog-str) match) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all)))))) + (if (verilog-re-search-forward "\\" (verilog-get-end-of-line) t) + (verilog-declaration-end) + (forward-line 1))))) + +(defun verilog-type-completion () + "Calculate all possible completions for types." + (let ((start (point)) + goon) + ;; Search for all reachable type declarations + (while (or (verilog-beg-of-defun) + (setq goon (not goon))) + (save-excursion + (if (and (< start (prog1 (save-excursion (verilog-end-of-defun) + (point)) + (forward-char 1))) + (verilog-re-search-forward + "\\\\|\\<\\(begin\\|function\\|procedure\\)\\>" + start t) + (not (match-end 1))) + ;; Check current type declaration + (verilog-get-completion-decl)))))) + +(defun verilog-var-completion () + "Calculate all possible completions for variables (or constants)." + nil) +; Not done yet; in 1.99 perhaps +; (let ((start (point)) +; goon twice) +; ;; Search for all reachable var declarations +; (while (or (verilog-beg-of-defun) +; (setq goon (not goon))) +; (save-excursion +; (if (> start (prog1 (save-excursion (verilog-end-of-defun) +; (point)))) +; () ; Declarations not reacable +; (cond ((and (verilog-re-search-forward verilog-declaration-re start t) +; ;; Check var/const declarations +; (verilog-get-completion-decl))))))))) + + +(defun verilog-keyword-completion (keyword-list) + "Give list of all possible completions of keywords in KEYWORD-LIST." + (mapcar '(lambda (s) + (if (string-match (concat "\\<" verilog-str) s) + (if (or (null verilog-pred) + (funcall verilog-pred s)) + (setq verilog-all (cons s verilog-all))))) + keyword-list)) + +;; Function passed to completing-read, try-completion or +;; all-completions to get completion on STR. If predicate is non-nil, +;; it must be a function to be called for every match to check if this +;; should really be a match. If flag is t, the function returns a list +;; of all possible completions. If it is nil it returns a string, the +;; longest possible completion, or t if STR is an exact match. If flag +;; is 'lambda, the function returns t if STR is an exact match, nil +;; otherwise. + +(defun verilog-completion (verilog-str verilog-pred verilog-flag) + (save-excursion + (let ((verilog-all nil)) + ;; Set buffer to use for searching labels. This should be set + ;; within functins which use verilog-completions + (set-buffer verilog-buffer-to-use) + + ;; Determine what should be completed + (let ((state (car (verilog-calculate-indent)))) + (cond ((eq state 'defun) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'module) + (verilog-keyword-completion verilog-defun-keywords)) + + ((eq state 'block) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-block-keywords)) + + ((eq state 'case) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-case-keywords)) + + ((eq state 'tf) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-tf-keywords)) + + (t;--Anywhere else + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'both) + (verilog-keyword-completion verilog-separator-keywords)))) + + ;; Now we have built a list of all matches. Give response to caller + (verilog-completion-response)))) + +(defun verilog-completion-response () + (cond ((or (equal verilog-flag 'lambda) (null verilog-flag)) + ;; This was not called by all-completions + (if (null verilog-all) + ;; Return nil if there was no matching label + nil + ;; Get longest string common in the labels + (let* ((elm (cdr verilog-all)) + (match (car verilog-all)) + (min (length match)) + tmp) + (if (string= match verilog-str) + ;; Return t if first match was an exact match + (setq match t) + (while (not (null elm)) + ;; Find longest common string + (if (< (setq tmp (verilog-string-diff match (car elm))) min) + (progn + (setq min tmp) + (setq match (substring match 0 min)))) + ;; Terminate with match=t if this is an exact match + (if (string= (car elm) verilog-str) + (progn + (setq match t) + (setq elm nil)) + (setq elm (cdr elm))))) + ;; If this is a test just for exact match, return nil ot t + (if (and (equal verilog-flag 'lambda) (not (equal match 't))) + nil + match)))) + ;; If flag is t, this was called by all-completions. Return + ;; list of all possible completions + (verilog-flag + verilog-all))) + +(defvar verilog-last-word-numb 0) +(defvar verilog-last-word-shown nil) +(defvar verilog-last-completions nil) + +(defun verilog-complete-word () + "Complete word at current point. +\(See also `verilog-toggle-completions', `verilog-type-keywords', +`verilog-start-keywords' and `verilog-separator-keywords'.)" + (interactive) + (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) + (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) + (verilog-str (buffer-substring b e)) + ;; The following variable is used in verilog-completion + (verilog-buffer-to-use (current-buffer)) + (allcomp (if (and verilog-toggle-completions + (string= verilog-last-word-shown verilog-str)) + verilog-last-completions + (all-completions verilog-str 'verilog-completion))) + (match (if verilog-toggle-completions + "" (try-completion + verilog-str (mapcar '(lambda (elm) + (cons elm 0)) allcomp))))) + ;; Delete old string + (delete-region b e) + + ;; Toggle-completions inserts whole labels + (if verilog-toggle-completions + (progn + ;; Update entry number in list + (setq verilog-last-completions allcomp + verilog-last-word-numb + (if (>= verilog-last-word-numb (1- (length allcomp))) + 0 + (1+ verilog-last-word-numb))) + (setq verilog-last-word-shown (elt allcomp verilog-last-word-numb)) + ;; Display next match or same string if no match was found + (if (not (null allcomp)) + (insert "" verilog-last-word-shown) + (insert "" verilog-str) + (message "(No match)"))) + ;; The other form of completion does not necessarly do that. + + ;; Insert match if found, or the original string if no match + (if (or (null match) (equal match 't)) + (progn (insert "" verilog-str) + (message "(No match)")) + (insert "" match)) + ;; Give message about current status of completion + (cond ((equal match 't) + (if (not (null (cdr allcomp))) + (message "(Complete but not unique)") + (message "(Sole completion)"))) + ;; Display buffer if the current completion didn't help + ;; on completing the label. + ((and (not (null (cdr allcomp))) (= (length verilog-str) + (length match))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list allcomp)) + ;; Wait for a keypress. Then delete *Completion* window + (momentary-string-display "" (point)) + (delete-window (get-buffer-window (get-buffer "*Completions*"))) + ))))) + +(defun verilog-show-completions () + "Show all possible completions at current point." + (interactive) + (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) + (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) + (verilog-str (buffer-substring b e)) + ;; The following variable is used in verilog-completion + (verilog-buffer-to-use (current-buffer)) + (allcomp (if (and verilog-toggle-completions + (string= verilog-last-word-shown verilog-str)) + verilog-last-completions + (all-completions verilog-str 'verilog-completion)))) + ;; Show possible completions in a temporary buffer. + (with-output-to-temp-buffer "*Completions*" + (display-completion-list allcomp)) + ;; Wait for a keypress. Then delete *Completion* window + (momentary-string-display "" (point)) + (delete-window (get-buffer-window (get-buffer "*Completions*"))))) + + +(defun verilog-get-default-symbol () + "Return symbol around current point as a string." + (save-excursion + (buffer-substring (progn + (skip-chars-backward " \t") + (skip-chars-backward "a-zA-Z0-9_") + (point)) + (progn + (skip-chars-forward "a-zA-Z0-9_") + (point))))) + +(defun verilog-build-defun-re (str &optional arg) + "Return function/task/module starting with STR as regular expression. +With optional second arg non-nil, STR is the complete name of the instruction." + (if arg + (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "\\)\\>") + (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>"))) + +;; Function passed to completing-read, try-completion or +;; all-completions to get completion on any function name. If +;; predicate is non-nil, it must be a function to be called for every +;; match to check if this should really be a match. If flag is t, the +;; function returns a list of all possible completions. If it is nil +;; it returns a string, the longest possible completion, or t if STR +;; is an exact match. If flag is 'lambda, the function returns t if +;; STR is an exact match, nil otherwise. + + +(defun verilog-comp-defun (verilog-str verilog-pred verilog-flag) + (save-excursion + (let ((verilog-all nil) + match) + + ;; Set buffer to use for searching labels. This should be set + ;; within functins which use verilog-completions + (set-buffer verilog-buffer-to-use) + + (let ((verilog-str verilog-str)) + ;; Build regular expression for functions + (if (string= verilog-str "") + (setq verilog-str (verilog-build-defun-re "[a-zA-Z_]")) + (setq verilog-str (verilog-build-defun-re verilog-str))) + (goto-char (point-min)) + + ;; Build a list of all possible completions + (while (verilog-re-search-forward verilog-str nil t) + (setq match (buffer-substring (match-beginning 2) (match-end 2))) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all))))) + + ;; Now we have built a list of all matches. Give response to caller + (verilog-completion-response)))) + +(defun verilog-goto-defun () + "Move to specified Verilog module/task/function. +The default is a name found in the buffer around point." + (interactive) + (let* ((default (verilog-get-default-symbol)) + ;; The following variable is used in verilog-comp-function + (verilog-buffer-to-use (current-buffer)) + (default (if (verilog-comp-defun default nil 'lambda) + default "")) + (label (if (not (string= default "")) + ;; Do completion with default + (completing-read (concat "Label: (default " default ") ") + 'verilog-comp-defun nil t "") + ;; There is no default value. Complete without it + (completing-read "Label: " + 'verilog-comp-defun nil t "")))) + ;; If there was no response on prompt, use default value + (if (string= label "") + (setq label default)) + ;; Goto right place in buffer if label is not an empty string + (or (string= label "") + (progn + (goto-char (point-min)) + (re-search-forward (verilog-build-defun-re label t)) + (beginning-of-line))))) +(defun verilog-showscopes () + "list all scopes in this module" + (interactive) + (let ( + (buffer (current-buffer)) + (linenum 1) + (nlines 0) + (first 1) + (prevpos (point-min)) + (final-context-start (make-marker)) + (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)") + ) + (with-output-to-temp-buffer "*Occur*" + (save-excursion + (message (format "Searching for %s ..." regexp)) + ;; Find next match, but give up if prev match was at end of buffer. + (while (and (not (= prevpos (point-max))) + (verilog-re-search-forward regexp nil t)) + (goto-char (match-beginning 0)) + (beginning-of-line) + (save-match-data + (setq linenum (+ linenum (count-lines prevpos (point))))) + (setq prevpos (point)) + (goto-char (match-end 0)) + (let* ((start (save-excursion + (goto-char (match-beginning 0)) + (forward-line (if (< nlines 0) nlines (- nlines))) + (point))) + (end (save-excursion + (goto-char (match-end 0)) + (if (> nlines 0) + (forward-line (1+ nlines)) + (forward-line 1)) + (point))) + (tag (format "%3d" linenum)) + (empty (make-string (length tag) ?\ )) + tem) + (save-excursion + (setq tem (make-marker)) + (set-marker tem (point)) + (set-buffer standard-output) + (setq occur-pos-list (cons tem occur-pos-list)) + (or first (zerop nlines) + (insert "--------\n")) + (setq first nil) + (insert-buffer-substring buffer start end) + (backward-char (- end start)) + (setq tem (if (< nlines 0) (- nlines) nlines)) + (while (> tem 0) + (insert empty ?:) + (forward-line 1) + (setq tem (1- tem))) + (let ((this-linenum linenum)) + (set-marker final-context-start + (+ (point) (- (match-end 0) (match-beginning 0)))) + (while (< (point) final-context-start) + (if (null tag) + (setq tag (format "%3d" this-linenum))) + (insert tag ?:))))))) + (set-buffer-modified-p nil)))) +;;; verilog.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/mu/mu-cite.el --- a/lisp/mu/mu-cite.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/mu/mu-cite.el Mon Aug 13 09:13:56 2007 +0200 @@ -6,7 +6,7 @@ ;; MINOURA Makoto ;; Shuhei KOBAYASHI ;; Maintainer: Shuhei KOBAYASHI -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: mail, news, citation ;; This file is part of MU (Message Utilities). @@ -54,14 +54,14 @@ ;;; (defconst mu-cite/RCS-ID - "$Id: mu-cite.el,v 1.3 1997/01/30 02:22:36 steve Exp $") + "$Id: mu-cite.el,v 1.4 1997/02/15 22:21:09 steve Exp $") (defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) ;;; @ formats ;;; -(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n>]+>+[ \t]*\\|^[ \t]*$\\)" +(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)" "*Regexp to match the citation prefix. If match, mu-cite doesn't insert citation prefix.") @@ -390,10 +390,13 @@ ;;; @ message editing utilities ;;; - + (defvar citation-mark-chars ">}|" "*String of characters for citation delimiter. [mu-cite.el]") +(defvar citation-disable-chars "<{" + "*String of characters not allowed as citation-prefix.") + (defun detect-paragraph-cited-prefix () (save-excursion (goto-char (point-min)) @@ -410,7 +413,10 @@ (progn (end-of-line)(point)))) (setq ret (string-compare-from-top prefix str)) ) - (setq prefix (second ret)) + (setq prefix + (if (stringp ret) + ret + (second ret))) (setq i (1+ i)) ) (cond ((> i 1) prefix) @@ -432,8 +438,10 @@ prefix))) ((progn (goto-char (point-max)) - (re-search-backward (concat "[" citation-mark-chars "]") - nil t) + (re-search-backward + (concat "[" citation-disable-chars "]") nil t) + (re-search-backward + (concat "[" citation-mark-chars "]") nil t) ) (goto-char (match-end 0)) (if (looking-at "[ \t]+") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/mule/canna.el --- a/lisp/mule/canna.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/mule/canna.el Mon Aug 13 09:13:56 2007 +0200 @@ -381,7 +381,11 @@ "Use input character as a key of complex translation input such as\n\ kana-to-kanji translation." (interactive "*p") - (canna:functional-insert-command2 last-command-char arg) ) + (let ((ch)) + (if (char-or-char-int-p arg) + (setq ch last-command-char) + (setq ch (event-to-character last-command-event))) + (canna:functional-insert-command2 ch arg) )) (defun canna:functional-insert-command2 (ch arg) "This function actualy isert a converted Japanese string." @@ -647,7 +651,11 @@ (use-local-map canna:*minibuffer-local-map-backup*) (set-window-buffer (minibuffer-window) canna:*saved-minibuffer*) (select-window canna:*previous-window*) - (canna:functional-insert-command2 last-command-char arg) ) + (let ((ch)) + (if (char-or-char-int-p arg) + (setq ch last-command-char) + (setq ch (event-to-character last-command-event))) + (canna:functional-insert-command2 ch arg) )) ;;; ;;; $B$+$s$J%b!<%I$N (car current-time) (car last-input-time)) + (> (cadr current-time) (cdr last-input-time)))) + ;; turn cursor off only if more than a second since + ;; last input + (set-specifier text-cursor-visible-p nil window)) + (set-specifier text-cursor-visible-p t window)) + (remove-specifier text-cursor-visible-p blink-cursor-last-selected-window) (setq blink-cursor-last-selected-window window) (set-specifier text-cursor-visible-p nil window))))) +; Turn on cursor after every command +(defun blink-cursor-post-command-hook () + (let ((inhibit-quit t) + (window (selected-window))) + (if blink-cursor-lost-focus + nil + (set-specifier text-cursor-visible-p t window)))) + (defun blink-cursor-reenable-cursor () (if blink-cursor-last-selected-window (progn @@ -63,6 +77,7 @@ (add-hook 'deselect-frame-hook 'blink-cursor-deselect-frame-hook) (add-hook 'select-frame-hook 'blink-cursor-select-frame-hook) +(add-hook 'post-command-hook 'blink-cursor-post-command-hook) (defvar blink-cursor-timeout 1.0) (defvar blink-cursor-timeout-id nil) @@ -96,4 +111,11 @@ (if blink-cursor-mode (setq blink-cursor-timeout-id (add-timeout (/ (float timeout) 2) 'blink-cursor-callback nil - (/ (float timeout) 2))))) + (/ (float timeout) 2)))) + ; initialize last-input-time + (if (not last-input-time) + (setq last-input-time (cons 0 0)))) + +(provide 'blink-cursor) + +;;; blink-cursor.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/packages/fast-lock.el --- a/lisp/packages/fast-lock.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/packages/fast-lock.el Mon Aug 13 09:13:56 2007 +0200 @@ -4,27 +4,25 @@ ;; Author: Simon Marshall ;; Keywords: faces files -;; Version: 3.10.01 +;; Version: 3.10.02 + +;;; This file is part of GNU Emacs. -;; This file is part of XEmacs. -;; -;; XEmacs is free software; you can redistribute it and/or modify +;; 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 of the License, or -;; (at your option) any later version. -;; -;; XEmacs is distributed in the hope that it will be useful, +;; 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 XEmacs; see the file COPYING. If not, write to the +;; 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. -;;; Synched up with: FSF 19.34. - ;;; Commentary: ;; Purpose: @@ -55,14 +53,7 @@ ;; ;; Version control packages are likely to stamp all over file modification ;; times. Therefore the act of checking out may invalidate a cache. - -;; Feedback: -;; -;; Feedback is welcome. -;; To submit a bug report (or make comments) please use the mechanism provided: -;; -;; M-x fast-lock-submit-bug-report RET - +;;;;;^L ;; History: ;; ;; 0.02--1.00: @@ -166,7 +157,10 @@ ;; - Wrap with `save-buffer-state' (Ray Van Tassle report) ;; - Made `fast-lock-mode' wrap `font-lock-support-mode' ;; 3.10--3.11: - +;; - Made `fast-lock-get-face-properties' cope with face lists +;; - Added `fast-lock-verbose' +;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary +;;;;;^L (require 'font-lock) ;; Make sure fast-lock.el is supported. @@ -194,15 +188,29 @@ (,@ body) (when (and (not modified) (buffer-modified-p)) (set-buffer-modified-p nil))))) - (put 'save-buffer-state 'lisp-indent-function 1)) + (put 'save-buffer-state 'lisp-indent-function 1) + ;; + ;; We use this to verify that a face should be saved. + (defmacro fast-lock-save-facep (face) + "Return non-nil if FACE matches `fast-lock-save-faces'." + (` (or (null fast-lock-save-faces) + (if (symbolp (, face)) + (memq (, face) fast-lock-save-faces) + (let ((list (, face)) found) + (while list + (if (memq (car list) fast-lock-save-faces) + (setq list nil found t) + (setq list (cdr list)))) + found)))))) (defun fast-lock-submit-bug-report () "Submit via mail a bug report on fast-lock.el." (interactive) (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.01" + (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.02" '(fast-lock-cache-directories fast-lock-minimum-size - fast-lock-save-others fast-lock-save-events fast-lock-save-faces) + fast-lock-save-others fast-lock-save-events fast-lock-save-faces + fast-lock-verbose) nil nil (concat "Hi Si., @@ -212,11 +220,12 @@ Start a fresh editor via `" invocation-name " -no-init-file -no-site-file'. In the `*scratch*' buffer, evaluate:")))) +;; XEmacs menu system requires this to be autoloaded ;;;###autoload (defvar fast-lock-mode nil) (defvar fast-lock-cache-timestamp nil) ; for saving/reading (defvar fast-lock-cache-filename nil) ; for deleting - +;;;;;^L ;; User Variables: (defvar fast-lock-cache-directories '("." "~/.emacs-flc") @@ -266,7 +275,11 @@ font-lock-face-list) "Faces that will be saved in a Font Lock cache file. If nil, means information for all faces will be saved.") - + +(defvar fast-lock-verbose font-lock-verbose + "*If non-nil, means show status messages for cache processing. +If a number, only buffers greater than this size have processing messages.") +;;;;;^L ;; User Functions: ;;;###autoload @@ -293,9 +306,7 @@ Various methods of control are provided for the Font Lock cache. In general, see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', -`fast-lock-save-others' and `fast-lock-save-faces'. - -Use \\[fast-lock-submit-bug-report] to send bug reports or feedback." +`fast-lock-save-others' and `fast-lock-save-faces'." (interactive "P") ;; Only turn on if we are visiting a file. We could use `buffer-file-name', ;; but many packages temporarily wrap that to nil when doing their own thing. @@ -403,7 +414,7 @@ (defun turn-on-fast-lock () "Unconditionally turn on Fast Lock mode." (fast-lock-mode t)) - +;;;;;^L ;;; API Functions: (defun fast-lock-after-fontify-buffer () @@ -417,7 +428,7 @@ (defalias 'fast-lock-after-unfontify-buffer 'ignore) - +;;;;;^L ;; Miscellaneous Functions: (defun fast-lock-save-cache-after-save-file () @@ -496,7 +507,7 @@ (file-name-as-directory (expand-file-name directory)) (mapconcat 'char-to-string (apply 'append (mapcar mapchars bufile)) "") ".flc")))) - +;;;;;^L ;; Font Lock Cache Processing Functions: (defun fast-lock-save-cache-1 (file timestamp) @@ -504,8 +515,11 @@ ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES). ;; Returns non-nil if a save was attempted to a writable cache file. (let ((tpbuf (generate-new-buffer " *fast-lock*")) - (buname (buffer-name)) (saved t)) - (message "Saving %s font lock cache..." buname) + (verbose (if (numberp fast-lock-verbose) + (> (buffer-size) fast-lock-verbose) + fast-lock-verbose)) + (saved t)) + (if verbose (message "Saving %s font lock cache..." (buffer-name))) (condition-case nil (save-excursion (print (list 'fast-lock-cache-data 2 @@ -519,10 +533,10 @@ fast-lock-cache-filename file)) (error (setq saved 'error)) (quit (setq saved 'quit))) (kill-buffer tpbuf) - (message "Saving %s font lock cache...%s" buname - (cond ((eq saved 'error) "failed") - ((eq saved 'quit) "aborted") - (t "done"))) + (if verbose (message "Saving %s font lock cache...%s" (buffer-name) + (cond ((eq saved 'error) "failed") + ((eq saved 'quit) "aborted") + (t "done")))) ;; We return non-nil regardless of whether a failure occurred. saved)) @@ -539,23 +553,26 @@ ;; the current buffer's file timestamp matches the TIMESTAMP, and the current ;; buffer's font-lock-keywords are the same as KEYWORDS. (let ((buf-timestamp (visited-file-modtime)) - (buname (buffer-name)) (loaded t)) + (verbose (if (numberp fast-lock-verbose) + (> (buffer-size) fast-lock-verbose) + fast-lock-verbose)) + (loaded t)) (if (or (/= version 2) (buffer-modified-p) (not (equal timestamp buf-timestamp)) (not (equal keywords font-lock-keywords))) (setq loaded nil) - (message "Loading %s font lock cache..." buname) + (if verbose (message "Loading %s font lock cache..." (buffer-name))) (condition-case nil (fast-lock-set-face-properties properties) (error (setq loaded 'error)) (quit (setq loaded 'quit))) - (message "Loading %s font lock cache...%s" buname - (cond ((eq loaded 'error) "failed") - ((eq loaded 'quit) "aborted") - (t "done")))) + (if verbose (message "Loading %s font lock cache...%s" (buffer-name) + (cond ((eq loaded 'error) "failed") + ((eq loaded 'quit) "aborted") + (t "done"))))) (setq font-lock-fontified (eq loaded t) fast-lock-cache-timestamp (and (eq loaded t) timestamp)))) - +;;;;;^L ;; Text Properties Processing Functions: ;; This is faster, but fails if adjacent characters have different `face' text @@ -578,24 +595,47 @@ ; (setq start (next-single-property-change end 'face))) ; properties))) +;; This copes if adjacent characters have different `face' text properties, but +;; fails if they are lists. +;(defun fast-lock-get-face-properties () +; "Return a list of all `face' text properties in the current buffer. +;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) +;where VALUE is a `face' property value and STARTx and ENDx are positions. +;Only those `face' VALUEs in `fast-lock-save-faces' are returned." +; (save-restriction +; (widen) +; (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max)) +; properties regions face start end) +; (while faces +; (setq face (car faces) faces (cdr faces) regions () end (point-min)) +; ;; Make a list of start/end regions with `face' property face. +; (while (setq start (text-property-any end limit 'face face)) +; (setq end (or (text-property-not-all start limit 'face face) limit) +; regions (cons start (cons end regions)))) +; ;; Add `face' face's regions, if any, to properties. +; (when regions +; (push (cons face regions) properties))) +; properties))) + (defun fast-lock-get-face-properties () "Return a list of all `face' text properties in the current buffer. Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) -where VALUE is a `face' property value and STARTx and ENDx are positions. -Only those `face' VALUEs in `fast-lock-save-faces' are returned." +where VALUE is a `face' property value and STARTx and ENDx are positions." (save-restriction (widen) - (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max)) - properties regions face start end) - (while faces - (setq face (car faces) faces (cdr faces) regions () end (point-min)) - ;; Make a list of start/end regions with `face' property face. - (while (setq start (text-property-any end limit 'face face)) - (setq end (or (text-property-not-all start limit 'face face) limit) - regions (cons start (cons end regions)))) - ;; Add `face' face's regions, if any, to properties. - (when regions - (push (cons face regions) properties))) + (let ((start (text-property-not-all (point-min) (point-max) 'face nil)) + (limit (point-max)) end properties value cell) + (while start + (setq end (next-single-property-change start 'face nil limit) + value (get-text-property start 'face)) + ;; Make, or add to existing, list of regions with same `face'. + (cond ((setq cell (assoc value properties)) + (setcdr cell (cons start (cons end (cdr cell))))) + ((fast-lock-save-facep value) + (push (list value start end) properties))) + (setq start (if (get-text-property end 'face) + end + (next-single-property-change end 'face)))) properties))) (defun fast-lock-set-face-properties (properties) @@ -614,7 +654,7 @@ (while regions (set-text-properties (nth 0 regions) (nth 1 regions) plist) (setq regions (nthcdr 2 regions))))))) - +;;;;;^L ;; Functions for XEmacs: (when (save-match-data (string-match "XEmacs" (emacs-version))) @@ -633,13 +673,12 @@ (function (lambda (extent ignore) (let ((value (extent-face extent))) ;; We're only interested if it's one of `fast-lock-save-faces'. - (when (and value (or (null fast-lock-save-faces) - (memq value fast-lock-save-faces))) + (when (and value (fast-lock-save-facep value)) (let ((start (extent-start-position extent)) (end (extent-end-position extent))) ;; Make or add to existing list of regions with the same ;; `face' property value. - (if (setq cell (assq value properties)) + (if (setq cell (assoc value properties)) (setcdr cell (cons start (cons end (cdr cell)))) (push (list value start end) properties)))) ;; Return nil to keep `map-extents' going. @@ -680,7 +719,7 @@ (unless (fboundp 'font-lock-compile-keywords) (defalias 'font-lock-compile-keywords 'identity)) - +;;;;;^L ;; Install ourselves: (add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/packages/hexl.el --- a/lisp/packages/hexl.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/packages/hexl.el Mon Aug 13 09:13:56 2007 +0200 @@ -706,8 +706,8 @@ (define-key hexl-mode-map "\C-e" 'hexl-end-of-line) (define-key hexl-mode-map "\C-f" 'hexl-forward-char) - (if (not (eq (key-binding (char-to-string help-char)) 'help-command)) - (define-key hexl-mode-map (char-to-string help-char) 'undefined)) + (if (not (eq (key-binding (vector help-char)) 'help-command)) + (define-key hexl-mode-map (vector help-char) 'undefined)) (define-key hexl-mode-map "\C-i" 'hexl-self-insert-command) (define-key hexl-mode-map "\C-j" 'hexl-self-insert-command) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/packages/info.el --- a/lisp/packages/info.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 09:13:56 2007 +0200 @@ -1826,11 +1826,11 @@ (interactive) (if Info-standalone (save-buffers-kill-emacs) - (switch-to-buffer (prog1 (other-buffer (current-buffer)) - (bury-buffer (current-buffer)) - (if (featurep 'toolbar) - (if (frame-live-p toolbar-info-frame) - (delete-frame toolbar-info-frame))))))) + (bury-buffer (current-buffer)) + (if (and (featurep 'toolbar) + (eq toolbar-info-frame (selected-frame))) + (delete-frame toolbar-info-frame) + (switch-to-buffer (other-buffer (current-buffer)))))) (defun Info-undefined () "Make command be undefined in Info." diff -r 498bf5da1c90 -r 0d2f883870bc lisp/packages/terminal.el --- a/lisp/packages/terminal.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/packages/terminal.el Mon Aug 13 09:13:56 2007 +0200 @@ -100,7 +100,7 @@ (define-key map "m" 'te-toggle-more-processing) (define-key map "x" 'te-escape-extended-command) (define-key map "?" 'te-escape-help) - (define-key map (char-to-string help-char) 'te-escape-help) + (define-key map (vector help-char) 'te-escape-help) (setq terminal-escape-map map))) (defvar te-escape-command-alist '()) @@ -139,7 +139,7 @@ (define-key map s 'te-more-break-unwind) (setq i (1+ i)))) - (define-key map (char-to-string help-char) 'te-more-break-help) + (define-key map (vector help-char) 'te-more-break-help) (define-key map " " 'te-more-break-resume) (define-key map "\C-l" 'redraw-display) (define-key map "\C-o" 'te-more-break-flush-pending-output) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/packages/webjump.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages/webjump.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,493 @@ +;;; webjump.el --- programmable Web hotlist + +;; Copyright (C) 1996 Free Software Foundation + +;; Author: Neil W. Van Dyke +;; Created: Fri 09 Aug 1996 +;; Version: 1.4 +;; Keywords: webjump web www browse-url +;; X-URL: http://www.cs.brown.edu/people/nwv/ + +;; This file is not yet part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify it under the +;; terms of the GNU General Public License as published by the Free Software +;; Foundation; either version 2, or (at your option) any later version. + +;; This is distributed in the hope that it will be useful, but WITHOUT ANY +;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;; details. + +;; You should have received a copy of the GNU General Public License along with +;; GNU Emacs; see the file COPYING. If not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +;;; Change Log: + +;; [Version 1.4, Tue 17 Sep 1995, nwv] Removed the evil "defconst-TEST" that +;; slipped into 1.3. Organized webjump-sample-sites and modified the content a +;; bit. + +;; [Version 1.3, Fri 30 Aug 1996, nwv] Fixed broken `if' function in +;; `webjump-to-javaapi' (bugfix already posted). Added `webjump-to-iwin'. +;; Added comment on purpose of `webjump-sample-sites'. Added +;; `webjump-read-choice'. + +;; [Version 1.2, Fri 16 Aug 1996, nwv] Oops, got Gamelan mixed up with Digital +;; Espresso somehow. Added `mirrors' builtin and used it for the sample GNU +;; Archive site. Added some other sample sites. Split sample sites out into +;; separate constant. Misc. small changes. Copyright has been transferred to +;; the FSF. + +;; [Version 1.1, Sat 10 Aug 1996, nwv] Added missing call to `webjump-url-fix' +;; (thanks to Istvan Marko for pointing this out). Added +;; ``builtins'' concept in order to support `simple-query' builtin for covering +;; the majority of cases. Added a couple more sample sites. + +;; [Version 1.0, Fri 09 Aug 1996, nwv] Wrote initial version and posted to +;; gnu.emacs.sources. + +;;; Commentary: + +;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can +;; quickly be invoked in your Web browser. Each Web site in the hotlist has a +;; name, and you select the desired site name via a completing string prompt in +;; the minibuffer. The URL for each Web site is defined as a static string or +;; a built-in or custom function, allowing interactive prompting for +;; site-specific queries and options. + +;; Note that WebJump was originally intended to complement your conventional +;; browser-based hotlist, not replace it. (Though there's no reason you +;; couldn't use WebJump for your entire hotlist if you were so inclined.) + +;; The `webjump-sites' variable, which defines the hotlist, defaults to some +;; example sites. You'll probably want to override it with your own favorite +;; sites. The documentation for the variable describes the syntax. + +;; You may wish to add something like the following to your `.emacs' file: +;; +;; (load "webjump") +;; (global-set-key "\C-c\C-j" 'webjump) +;; (setq webjump-sites +;; (append '( +;; ("My Home Page" . "www.someisp.net/users/joebobjr/") +;; ("Pop's Site" . "www.joebob-and-son.com/") +;; ) +;; webjump-sample-sites)) +;; +;; The above loads this package, binds `C-c C-j' to invoke WebJump, and adds +;; your personal favorite sites to the hotlist. + +;; The `webjump-sample-sites' constant mostly contains sites that are expected +;; to be generally useful to Emacs users or that have some sort of query which +;; can be coded in WebJump. There are two main goals of this sample site list: +;; (1) demonstrate WebJump capabilities and usage; (2) provide definitions for +;; many popular sites so that people don't have to reinvent the wheel. A few +;; assorted other sites have been thrown in on a whim. No commercial sites are +;; included unless they provide a free, generally-useful service. Inclusion of +;; a site does not represent an endorsement. Please contact the maintainer +;; with change requests. + +;; The `browse-url' package is used to submit URLs to the browser, so any +;; browser-specific configuration should be done there. + +;; WebJump inherits a small amount code from my `altavista.el' package, and is +;; intended to obsolete that package. + +;;; Code: + +;;-------------------------------------------------------- Package Dependencies + +(require 'browse-url) + +;;------------------------------------------------------ Package Identification + +(defconst webjump-version "1.4") +(defconst webjump-author "Neil W. Van Dyke ") +(defconst webjump-maintainer-address "nwv@acm.org") +(defconst webjump-vc-id + "$Id: webjump.el,v 1.1 1997/02/14 19:21:27 steve Exp $") + +;;------------------------------------------------------------------- Constants + +(defconst webjump-sample-sites + '( + + ;; FSF, not including Emacs-specific. + ("GNU Project FTP Archive". + [mirrors "ftp://prep.ai.mit.edu/pub/gnu/" + ;; ASIA: + "ftp://ftp.cs.titech.ac.jp" + "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/prep" + "ftp://cair-archive.kaist.ac.kr/pub/gnu" + "ftp://ftp.nectec.or.th/pub/mirrors/gnu" + ;; AUSTRALIA: + "ftp://archie.au/gnu" + "ftp://archie.oz/gnu" + "ftp://archie.oz.au/gnu" + ;; AFRICA: + "ftp://ftp.sun.ac.za/pub/gnu" + ;; MIDDLE-EAST: + "ftp://ftp.technion.ac.il/pub/unsupported/gnu" + ;; EUROPE: + "ftp://irisa.irisa.fr/pub/gnu" + "ftp://ftp.univ-lyon1.fr/pub/gnu" + "ftp://ftp.mcc.ac.uk" + "ftp://unix.hensa.ac.uk/mirrors/uunet/systems/gnu" + "ftp://src.doc.ic.ac.uk/gnu" + "ftp://ftp.ieunet.ie/pub/gnu" + "ftp://ftp.eunet.ch" + "ftp://nic.switch.ch/mirror/gnu" + "ftp://ftp.informatik.rwth-aachen.de/pub/gnu" + "ftp://ftp.informatik.tu-muenchen.de" + "ftp://ftp.win.tue.nl/pub/gnu" + "ftp://ftp.nl.net" + "ftp://ftp.etsimo.uniovi.es/pub/gnu" + "ftp://ftp.funet.fi/pub/gnu" + "ftp://ftp.denet.dk" + "ftp://ftp.stacken.kth.se" + "ftp://isy.liu.se" + "ftp://ftp.luth.se/pub/unix/gnu" + "ftp://ftp.sunet.se/pub/gnu" + "ftp://archive.eu.net" + ;; SOUTH AMERICA: + "ftp://ftp.inf.utfsm.cl/pub/gnu" + "ftp://ftp.unicamp.br/pub/gnu" + ;; WESTERN CANADA: + "ftp://ftp.cs.ubc.ca/mirror2/gnu" + ;; USA: + "ftp://wuarchive.wustl.edu/systems/gnu" + "ftp://labrea.stanford.edu" + "ftp://ftp.digex.net/pub/gnu" + "ftp://ftp.kpc.com/pub/mirror/gnu" + "ftp://f.ms.uky.edu/pub3/gnu" + "ftp://jaguar.utah.edu/gnustuff" + "ftp://ftp.hawaii.edu/mirrors/gnu" + "ftp://uiarchive.cso.uiuc.edu/pub/gnu" + "ftp://ftp.cs.columbia.edu/archives/gnu/prep" + "ftp://gatekeeper.dec.com/pub/GNU" + "ftp://ftp.uu.net/systems/gnu"]) + ("GNU Project Home Page" . "www.fsf.org") + ;"www.gnu.ai.mit.edu" + ;"agnes.dida.physik.uni-essen.de/~gnu" + + ;; Emacs. + ("Eieio" . "ftp.ultranet.com/pub/zappo/") + ("Emacs Lisp Archive" . + "ftp://archive.cis.ohio-state.edu/pub/gnu/emacs/elisp-archive/") + ("Insidious Big Brother Database" . "home.netscape.com/people/jwz/bbdb/") + ;"ftp.xemacs.org/pub/bbdb/" + ("Mailcrypt" . "cag-www.lcs.mit.edu/mailcrypt/") + ("XEmacs Home" . "www.xemacs.org") ; Doesn't hurt to have this here. :) + ("Yahoo: Emacs" . + "www.yahoo.com/Computers_and_Internet/Software/Editors/Emacs/") + + ;; General interest. + ("AltaVista" . + [simple-query + "www.altavista.digital.com" + "www.altavista.digital.com/cgi-bin/query?pg=aq&what=web&fmt=.&q=" + "&r=&d0=&d1="]) + ("Archie" . + [simple-query "http://hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl" + "http://hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl?query=" ""]) + ("Interactive Weather Information Network" . webjump-to-iwin) + ("Lycos" . + [simple-query "www.lycos.com" "www.lycos.com/cgi-bin/pursuit?query=" ""]) + ("Usenet FAQs" . + [simple-query "www.cis.ohio-state.edu/hypertext/faq/usenet/FAQ-List.html" + "www.cis.ohio-state.edu/htbin/search-usenet-faqs/form?find=" + ""]) + ("RTFM Usenet FAQs by Group" . + "ftp://rtfm.mit.edu/pub/usenet-by-group/") + ("RTFM Usenet FAQs by Hierachy" . + "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/") + ("Webster" . + [simple-query "c.gp.cs.cmu.edu:5103/prog/webster" + "gs213.sp.cs.cmu.edu/prog/webster?" ""]) + ("X Consortium Archive". "ftp.x.org") + ("Yahoo" . + [simple-query "www.yahoo.com" "search.yahoo.com/bin/search?p=" ""]) + ("Yahoo: Reference" "www.yahoo.com/Reference/") + + ;; Computer privacy and social issues. + ("Computer Professionals for Social Responsibility" . "www.cpsr.org/dox/") + ("Electronic Frontier Foundation" . "www.eff.org") + ("Pretty Good Privacy" . "web.mit.edu/network/pgp.html") + ("Risks Digest" . webjump-to-risks) + + ;; Java. + ("Digital Espresso" . + [simple-query "www.io.org/~mentor/DigitalEspresso.html" + "www.jars.com/cgi-bin/aglimpse/01?query=" + "&case=on&whole=on&errors=0&maxfiles=100&maxlines=30"]) + ("Java API" . webjump-to-javaapi) + + ;; Fun. + ("Bastard Operator from Hell" . "www.replay.com/bofh/") + ("Dilbert" . "www.unitedmedia.com/comics/dilbert/") + ("Playboy" . (if (webjump-adult-p) "www.playboy.com" "www.whitehouse.gov")) + + ;; Author's indulgence. + ("Brown University" . + [simple-query "www.brown.edu" "www.brown.edu/cgi-local/bsearch?" ""]) + + ) + "Sample hotlist for WebJump.") + +(defconst webjump-state-to-postal-alist + '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar") + ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct") + ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi") + ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia") + ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me") + ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi") + ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo") + ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv") + ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm") + ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd") + ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or") + ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc") + ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx") + ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va") + ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi") + ("Wyoming" . "wy"))) + +;;------------------------------------------------------------ Option Variables + +(defvar webjump-sites + webjump-sample-sites + "*Hotlist for WebJump. + +The hotlist is represented as an association list, with the CAR of each cell +being the name of the Web site, and the CDR being the definition for the URL of +that site. The URL definition can be a string (the URL), a vector (specifying +a special \"builtin\" which returns a URL), a symbol (name of a function which +returns a URL), or a list (which when `eval'ed yields a URL). + +If the URL definition is a vector, then a \"builtin\" is used. A builtin has a +Lisp-like syntax, with the name as the first element of the vector, and any +arguments as the following elements. The three current builtins are `name', +which returns the name of the site as the URL, `simple-query', which +returns a URL that is a function of a query entered by the user, and `mirrors', +which allows the user to select from among multiple mirror sites for the same +content. + +The first argument to the `simple-query' builtin is a static URL to use if the +user enters a blank query. The second and third arguments are the prefix and +suffix, respectively, to add to the encoded query the user enters. This +builtin covers Web sites that have single-string searches with the query +embedded in the URL. + +The arguments to the `mirrors' builtin are URLs of mirror sites. + +If the symbol of a function is given, then the function will be called with the +Web site name (the one you specified in the CAR of the alist cell) as a +parameter. This might come in handy for various kludges. + +For convenience, if the `http://', `ftp://', or `file://' prefix is missing +from a URL, WebJump will make a guess at what you wanted and prepend it before +submitting the URL.") + +;;------------------------------------------------------- Sample Site Functions + +(defun webjump-to-iwin (name) + (let ((prefix "http://iwin.nws.noaa.gov/") + (state (webjump-read-choice name "state" + (append '(("Puerto Rico" . "pr")) + webjump-state-to-postal-alist)))) + (if state + (concat prefix "iwin/" state "/" + (webjump-read-choice name "option" + '(("Hourly Report" . "hourly") + ("State Forecast" . "state") + ("Local Forecast" . "local") + ("Zone Forecast" . "zone") + ("Short-Term Forecast" . "shortterm") + ("Weather Summary" . "summary") + ("Public Information" . "public") + ("Climatic Data" . "climate") + ("Aviation Products" . "aviation") + ("Hydro Products" . "hydro") + ("Special Weather" . "special") + ("Watches and Warnings" . "warnings")) + "zone") + ".html") + prefix))) + +(defun webjump-to-javaapi (name) + (let* ((prefix "http://www.javasoft.com/products/JDK/CurrentRelease/api/") + (packages '(("java.applet") ("java.awt") ("java.awt.image") + ("java.awt.peer") ("java.io") ("java.lang") ("java.net") + ("java.util") ("sun.tools.debug"))) + (completion-ignore-case t) + (package (completing-read (concat name " package: ") packages nil t))) + (if (webjump-null-or-blank-string-p package) + (concat prefix "packages.html") + (concat prefix "Package-" package ".html")))) + +(defun webjump-to-risks (name) + (let (issue volume) + (if (and (setq volume (webjump-read-number (concat name " volume"))) + (setq issue (webjump-read-number (concat name " issue")))) + (format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue) + "catless.ncl.ac.uk/Risks/"))) + +;;-------------------------------------------------------------- Core Functions + +;;;###autoload +(defun webjump () + "Jumps to a Web site from a programmable hotlist. + +See the documentation for the `webjump-sites' variable for how to customize the +hotlist. + +Feedback on WebJump can be sent to the author, Neil W. Van Dyke , +or submitted via `\\[webjump-submit-bug-report]'. The latest version can be +gotten from `http://www.cs.brown.edu/people/nwv/'." + (interactive) + (let* ((completion-ignore-case t) + (item (assoc (completing-read "WebJump to site: " webjump-sites nil t) + webjump-sites)) + (name (car item)) + (expr (cdr item))) + (funcall browse-url-browser-function + (webjump-url-fix + (cond ((not expr) "") + ((stringp expr) expr) + ((vectorp expr) (webjump-builtin expr name)) + ((listp expr) (eval expr)) + ((symbolp expr) + (if (fboundp expr) + (funcall expr name) + (error "WebJump URL function \"%s\" undefined." expr))) + (t (error "WebJump URL expression for \"%s\" invalid." + name))))))) + +(defun webjump-adult-p () + (and (boundp 'age) (integerp age) (>= age 21))) + +(defun webjump-builtin (expr name) + (if (< (length expr) 1) + (error "WebJump URL builtin for \"%s\" empty." name)) + (let ((builtin (aref expr 0))) + (cond + ((eq builtin 'mirrors) + (if (= (length expr) 1) + (error + "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg.")) + (webjump-choose-mirror name (cdr (append expr nil)))) + ((eq builtin 'name) + name) + ((eq builtin 'simple-query) + (webjump-builtin-check-args expr name 3) + (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3))) + (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid." + builtin name))))) + +(defun webjump-builtin-check-args (expr name count) + (or (= (length expr) (1+ count)) + (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args." + (aref expr 0) name count))) + +(defun webjump-choose-mirror (name urls) + (webjump-read-url-choice (concat name " mirror") + urls + (webjump-mirror-default urls))) + +(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix) + (let ((query (webjump-read-string (concat name " query")))) + (if query + (concat query-prefix (webjump-url-encode query) query-suffix) + noquery-url))) + +(defun webjump-mirror-default (urls) + ;; Note: This should be modified to apply some simple kludges/heuristics to + ;; pick a site which is likely "close". As a tie-breaker among candidates + ;; judged equally desirable, randomness should be used. + (car urls)) + +(defun webjump-read-choice (name what choices &optional default) + (let* ((completion-ignore-case t) + (choice (completing-read (concat name " " what ": ") choices nil t))) + (if (webjump-null-or-blank-string-p choice) + default + (cdr (assoc choice choices))))) + +(defun webjump-read-number (prompt) + ;; Note: I should make this more robust someday. + (let ((input (webjump-read-string prompt))) + (if input (string-to-number input)))) + +(defun webjump-read-string (prompt) + (let ((input (read-string (concat prompt ": ")))) + (if (webjump-null-or-blank-string-p input) nil input))) + +(defun webjump-read-url-choice (what urls &optional default) + ;; Note: Convert this to use `webjump-read-choice' someday. + (let* ((completions (mapcar (function (lambda (n) (cons n n))) + urls)) + (input (completing-read (concat what + ;;(if default " (RET for default)" "") + ": ") + completions + nil + t))) + (if (webjump-null-or-blank-string-p input) + default + (car (assoc input completions))))) + +(defun webjump-null-or-blank-string-p (str) + (or (null str) (string-match "^[ \t]*$" str))) + +(defun webjump-submit-bug-report () + "Submit via mail a bug report on WebJump." + (interactive) + (require 'reporter) + (reporter-submit-bug-report + webjump-maintainer-address + (concat "webjump.el " webjump-version " " webjump-vc-id) + '(webjump-sites) + nil + nil + (concat + "[Dear bug report submitter: Please ensure that the variable dumps\n" + "below do not contain any information you consider private.]\n"))) + +(defun webjump-url-encode (str) + (mapconcat '(lambda (c) + (cond ((= c 32) "+") + ((or (and (>= c ?a) (<= c ?z)) + (and (>= c ?A) (<= c ?Z)) + (and (>= c ?0) (<= c ?9))) + (char-to-string c)) + (t (upcase (format "%%%02x" c))))) + str + "")) + +(defun webjump-url-fix (url) + (if (webjump-null-or-blank-string-p url) + "" + (webjump-url-fix-trailing-slash + (cond + ((string-match "^[a-zA-Z]+:" url) url) + ((string-match "^/" url) (concat "file://" url)) + ((string-match "^\\([^\\./]+\\)" url) + (concat (if (string= (downcase (match-string 1 url)) "ftp") + "ftp" + "http") + "://" + url)) + (t url))))) + +(defun webjump-url-fix-trailing-slash (url) + (if (string-match "^[a-zA-Z]+://[^/]+$" url) + (concat url "/") + url)) + +;;----------------------------------------------------------------------------- + +(provide 'webjump) + +;; webjump.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 09:13:56 2007 +0200 @@ -943,241 +943,74 @@ ;;;*** -;;;### (autoloads (ange-ftp-hook-function) "ange-ftp" "dired/ange-ftp.el") - -(defvar ange-ftp-path-format '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" 3 2 4) "\ -*Format of a fully expanded remote pathname. This is a cons -\(REGEXP . (HOST USER PATH)), where REGEXP is a regular expression matching -the full remote pathname, and HOST, USER, and PATH are the numbers of -parenthesized expressions in REGEXP for the components (in that order).") - -(autoload 'ange-ftp-hook-function "ange-ftp" nil nil nil) - -(or (assoc (car ange-ftp-path-format) file-name-handler-alist) (setq file-name-handler-alist (cons (cons (car ange-ftp-path-format) 'ange-ftp-hook-function) file-name-handler-alist))) - -;;;*** - -;;;### (autoloads (dired-make-permissions-interactive) "dired-chmod" "dired/dired-chmod.el") - -(autoload 'dired-make-permissions-interactive "dired-chmod" nil nil nil) - -;;;*** - -;;;### (autoloads (dired-cwd-make-magic) "dired-cwd" "dired/dired-cwd.el") - -(autoload 'dired-cwd-make-magic "dired-cwd" "\ -Modify COMMAND so that it's working directory is the current dired directory. -This works by binding `default-directory' to `(default-directory)'s value. -See also function `default-directory'." t nil) - -;;;*** - -;;;### (autoloads (dired-do-rename-list dired-do-rename-numeric) "dired-num" "dired/dired-num.el") - -(autoload 'dired-do-rename-numeric "dired-num" "\ -Rename all marked (or next ARG) files using numbers. -You are prompted for a format string, e.g \"part_%d_of_8\", and a starting -number, e.g. 1. If there are 8 marked files, this example will rename them to - - part_1_of_8 - part_2_of_8 - ... - part_8_of_8" t nil) - -(autoload 'dired-do-rename-list "dired-num" "\ -Rename all marked (or next ARG) files using elements from LIST. -You are prompted for a format string, e.g \"x_%s\", and the list, -e.g. '(foo bar zod). This example will rename the marked files to - - x_foo - x_bar - x_zod - -It is an error if LIST has not as many elements as there are files." t nil) - -;;;*** - -;;;### (autoloads (dired-rcs-mark-rcs-files dired-rcs-mark-rcs-locked-files) "dired-rcs" "dired/dired-rcs.el") - -(autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs" "\ -Mark all files that are under RCS control and RCS-locked. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." t nil) - -(autoload 'dired-rcs-mark-rcs-files "dired-rcs" "\ -Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." t nil) - -;;;*** - -;;;### (autoloads (dired-extra-startup) "dired-x" "dired/dired-x.el") - -(autoload 'dired-extra-startup "dired-x" "\ -Automatically put on dired-mode-hook to get extra dired features: -\\ - \\[dired-vm] -- VM on folder - \\[dired-rmail] -- Rmail on folder - \\[dired-do-insert-subdir] -- insert all marked subdirs - \\[dired-do-find-file] -- visit all marked files simultaneously - \\[dired-set-marker-char], \\[dired-restore-marker-char] -- change and display dired-marker-char dynamically. - \\[dired-omit-toggle] -- toggle omitting of files - \\[dired-mark-sexp] -- mark by lisp expression - \\[dired-do-unmark] -- replace existing marker with another. - \\[dired-mark-rcs-files] -- mark all RCS controlled files - \\[dired-mark-files-compilation-buffer] -- mark compilation files - \\[dired-copy-filename-as-kill] -- copy the file or subdir names into the kill ring. - You can feed it to other commands using \\[yank]. - -For more features, see variables - - dired-omit-files - dired-omit-extenstions - dired-dangerous-shell-command - dired-mark-keys - dired-local-variables-file - dired-find-subdir - dired-guess-have-gnutar - dired-auto-shell-command-alist - -See also functions - - dired-sort-on-size - dired-do-relsymlink - dired-flag-extension - dired-virtual - dired-jump-back - dired-jump-back-other-window -" t nil) - -;;;*** - -;;;### (autoloads (dired-noselect dired-other-frame dired-other-window dired) "dired" "dired/dired.el") - -(defvar dired-listing-switches (purecopy "-al") "\ -*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-chown-program (purecopy (if (memq system-type '(dgux-unix hpux usg-unix-v silicon-graphics-unix irix)) "chown" "/etc/chown")) "\ -*Name of chown command (usully `chown' or `/etc/chown').") - -(defvar dired-ls-program (purecopy "ls") "\ -*Absolute or relative name of the ls program used by dired.") - -(defvar dired-ls-F-marks-symlinks t "\ -*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). - -Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to -nil, if it gives `bar@ -> foo', set it to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t.") - -(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") "\ -*Regexp of files to skip when moving point to the first file of a new directory listing. -Nil means move to the subdir line, t means move to first file.") - -(defvar dired-keep-marker-move t "\ -If t, moved marked files are marked if their originals were. -If a character, those files (marked or not) are marked with that character.") - -(defvar dired-keep-marker-copy ?C "\ -If t, copied files are marked if their source files were. -If a character, those files are always marked with that character.") - -(defvar dired-keep-marker-hardlink ?H "\ -If t, hard-linked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -(defvar dired-keep-marker-symlink ?Y "\ -If t, symlinked marked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -(defvar dired-dwim-target nil "\ -*If non-nil, dired tries to guess a default target directory: -If there is a dired buffer displayed in the next window, use -its current subdir, instead of the current subdir of this dired -buffer. - -The target is used in the prompt for file copy, move etc.") - -(defvar dired-copy-preserve-time nil "\ -*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -(define-key ctl-x-map "d" 'dired) - -(autoload 'dired "dired" "\ -\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -With an optional prefix argument you can specify the ls SWITCHES that are used. -Dired displays a list of files in DIRNAME (which may also have - shell wildcards appended to select certain files). -You can move around in it with the usual commands. -You can flag files for deletion with \\\\[dired-flag-file-deleted] and then delete them by - typing \\[dired-do-deletions]. -Type \\[describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) - -(define-key ctl-x-4-map "d" 'dired-other-window) - -(autoload 'dired-other-window "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) - -(define-key ctl-x-5-map "d" 'dired-other-frame) - -(autoload 'dired-other-frame "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." t nil) - -(autoload 'dired-noselect "dired" "\ -Like `dired' but returns the dired buffer as value, does not select it." nil nil) - -;;;*** - -;;;### (autoloads (find-grep-dired find-name-dired find-dired) "find-dired" "dired/find-dired.el") - -(defvar find-ls-option (purecopy (if (eq system-type 'berkeley-unix) '("-ls" . "-gilsb") '("-exec ls -ld {} \\;" . "-ld"))) "\ -*Description of the option to `find' to produce an `ls -l'-type listing. -This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION -gives the option (or options) to `find' that produce the desired output. -LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output.") - -(defvar find-grep-options (purecopy (if (eq system-type 'berkeley-unix) "-s" "-q")) "\ -*Option to grep to be as silent as possible. -On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it. -On other systems, the closest you can come is to use `-l'.") - -(defvar find-dired-multiple-buffers nil "\ -*If non-nil, generates a new buffer for each find") - -(autoload 'find-dired "find-dired" "\ -Run `find' and go into dired-mode on a buffer of the output. -The command run (after changing into DIR) is - - find . \\( ARGS \\) -ls" t nil) - -(autoload 'find-name-dired "find-dired" "\ -Search DIR recursively for files matching the globbing pattern PATTERN, -and run dired on those files. -PATTERN is a shell wildcard (not an Emacs regexp) and need not be quoted. -The command run (after changing into DIR) is - - find . -name 'PATTERN' -ls" t nil) - -(autoload 'find-grep-dired "find-dired" "\ -Find files in DIR containing a regexp ARG and start Dired on output. -The command run (after changing into DIR) is - - find . -type f -exec test -r {} \\; -exec egrep -s ARG {} \\; -ls - -Thus ARG can also contain additional grep options." t nil) +;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "custom-edit" "custom/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 (widget-browse-at) "widget-browse" "custom/widget-browse.el") + +(autoload 'widget-browse-at "widget-browse" "\ +Browse the widget under point." t nil) + +;;;*** + +;;;### (autoloads (widget-delete widget-create) "widget-edit" "custom/widget-edit.el") + +(autoload 'widget-create "widget-edit" "\ +Create widget of TYPE. +The optional ARGS are additional keyword arguments." nil nil) + +(autoload 'widget-delete "widget-edit" "\ +Delete WIDGET." nil nil) + +;;;*** + +;;;### (autoloads (define-widget) "widget" "custom/widget.el") + +(autoload 'define-widget "widget" "\ +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." nil nil) ;;;*** @@ -1377,6 +1210,202 @@ ;;;*** +;;;### (autoloads nil "default-dir" "efs/default-dir.el") + +(defvar default-directory-function nil "\ +A function to call to compute the default-directory for the current buffer. +If this is nil, the function default-directory will return the value of the +variable default-directory. +Buffer local.") + +;;;*** + +;;;### (autoloads (dired-jump-back-other-frame dired-jump-back-other-window dired-jump-back dired-noselect dired-other-frame dired-other-window dired) "dired" "efs/dired.el") + +(defvar dired-compression-method 'compress "\ +*Type of compression program to use. +Give as a symbol. +Currently-recognized methods are: gzip pack compact compress. +To change this variable use \\[dired-do-compress] with a zero prefix.") + +(defvar dired-compression-method-alist '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") (pack ".z" ("pack" "-f") ("unpack")) (compact ".C" ("compact") ("uncompact"))) "\ +*Association list of compression method descriptions. + Each element of the table should be a list of the form + + (compress-type extension (compress-args) (decompress-args) force-flag) + + where + `compress-type' is a unique symbol in the alist to which + `dired-compression-method' can be set; + `extension' is the file extension (as a string) used by files compressed + by this method; + `compress-args' is a list of the path of the compression program and + flags to pass as separate arguments; + `decompress-args' is a list of the path of the decompression + program and flags to pass as separate arguments. + `force-flag' is the switch to pass to the command to force overwriting + of existing files. + + For example: + + (setq dired-compresssion-method-alist + (cons '(frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\") \"-f\") + dired-compression-method-alist)) + => ((frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\")) + (gzip \".gz\" (\"gzip\") (\"gunzip\")) + ...) + + See also: dired-compression-method ") + +(defvar dired-ls-program "ls" "\ +*Absolute or relative name of the ls program used by dired.") + +(defvar dired-listing-switches "-al" "\ +*Switches passed to ls for dired. MUST contain the `l' option. +Can contain even `F', `b', `i' and `s'.") + +(defvar dired-chown-program (if (memq system-type '(hpux dgux usg-unix-v)) "chown" "/etc/chown") "\ +*Name of chown command (usully `chown' or `/etc/chown').") + +(defvar dired-gnutar-program nil "\ +*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). +GNU tar's `z' switch is used for compressed tar files. +If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") + +(defvar dired-unshar-program nil "\ +*Set to the name of the unshar program, if you have it.") + +(defvar dired-local-variables-file ".dired" "\ +*If non-nil, filename for local variables for Dired. +If Dired finds a file with that name in the current directory, it will +temporarily insert it into the dired buffer and run `hack-local-variables'. + +Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on +local variables.") + +(defvar dired-kept-versions 2 "\ +*When cleaning directory, number of versions to keep.") + +(defvar dired-find-subdir nil "\ +*Determines whether dired tries to lookup a subdir in existing buffers. +If non-nil, dired does not make a new buffer for a directory if it can be +found (perhaps as subdir) in some existing dired buffer. If there are several +dired buffers for a directory, then the most recently used one is chosen. + +Dired avoids switching to the current buffer, so that if you have +a normal and a wildcard buffer for the same directory, C-x d RET will +toggle between those two.") + +(defvar dired-use-file-transformers t "\ +*Determines whether dired uses file transformers. +If non-nil `dired-do-shell-command' will apply file transformers to file names. +See \\[describe-function] for dired-do-shell-command for more information.") + +(defvar dired-dwim-target nil "\ +*If non-nil, dired tries to guess a default target directory. +This means that if there is a dired buffer displayed in the next window, +use its current subdir, instead of the current subdir of this dired buffer. +The target is put in the prompt for file copy, rename, etc.") + +(defvar dired-copy-preserve-time nil "\ +*If non-nil, Dired preserves the last-modified time in a file copy. +\(This works on only some systems.)\\ +Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") + +(defvar dired-no-confirm nil "\ +*If non-nil, a list of symbols for commands dired should not confirm. +It can be a sublist of + + '(byte-compile chgrp chmod chown compress copy delete hardlink load + move print shell symlink uncompress recursive-delete kill-file-buffer + kill-dired-buffer patch create-top-dir revert-subdirs) + +The meanings of most of the symbols are obvious. A few exceptions: + + 'compress applies to compression or decompression by any of the + compression program in `dired-compression-method-alist'. + + 'kill-dired-buffer applies to offering to kill dired buffers for + directories which have been deleted. + + 'kill-file-buffer applies to offering to kill buffers visiting files + which have been deleted. + + 'recursive-delete applies to recursively deleting non-empty + directories, and all of their contents. + + 'create-top-dir applies to `dired-up-directory' creating a new top level + directory for the dired buffer. + + 'revert-subdirs applies to re-reading subdirectories which have + been modified on disk. + +Note that this list also applies to remote files accessed with efs +or ange-ftp.") + +(defvar dired-backup-if-overwrite nil "\ +*Non-nil if Dired should ask about making backups before overwriting files. +Special value 'always suppresses confirmation.") + +(defvar dired-omit-files nil "\ +*If non-nil un-interesting files will be omitted from this dired buffer. +Use \\[dired-omit-toggle] to see these files. (buffer local)") + +(defvar dired-mail-reader 'rmail "\ +*Mail reader used by dired for dired-read-mail (\\[dired-read-mail]). +The symbols 'rmail and 'vm are the only two allowed values.") + +(define-key ctl-x-map "d" 'dired) + +(autoload 'dired "dired" "\ +\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Optional second argument SWITCHES specifies the `ls' options used. +\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Dired displays a list of files in DIRNAME (which may also have +shell wildcards appended to select certain files). If DIRNAME is a cons, +its first element is taken as the directory name and the resr as an explicit +list of files to make directory entries for. +\\You can move around in it with the usual commands. +You can flag files for deletion with \\[dired-flag-file-deletion] and then +delete them by typing \\[dired-expunge-deletions]. +Type \\[dired-describe-mode] after entering dired for more info. + +If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) + +(define-key ctl-x-4-map "d" 'dired-other-window) + +(autoload 'dired-other-window "dired" "\ +\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) + +(define-key ctl-x-5-map "d" 'dired-other-frame) + +(autoload 'dired-other-frame "dired" "\ +\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." t nil) + +(autoload 'dired-noselect "dired" "\ +Like `dired' but returns the dired buffer as value, does not select it." nil nil) + +(define-key ctl-x-map "\C-j" 'dired-jump-back) + +(autoload 'dired-jump-back "dired" "\ +Jump back to dired. +If in a file, dired the current directory and move to file's line. +If in dired already, pop up a level and goto old directory's line. +In case the proper dired file line cannot be found, refresh the dired + buffer and try again." t nil) + +(define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) + +(autoload 'dired-jump-back-other-window "dired" "\ +Like \\[dired-jump-back], but to other window." t nil) + +(define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) + +(autoload 'dired-jump-back-other-frame "dired" "\ +Like \\[dired-jump-back], but in another frame." t nil) + +;;;*** + ;;;### (autoloads (electric-buffer-list) "ebuff-menu" "electric/ebuff-menu.el") (autoload 'electric-buffer-list "ebuff-menu" "\ @@ -1871,6 +1900,67 @@ ;;;*** +;;;### (autoloads (mine-help mine-version mine) "mine" "games/mine.el") + +(autoload 'mine "mine" "\ +Play Mine. Optional prefix argument is the number of mines. + +To play Mine, type `\\[mine]' or `\\[universal-argument] NUM \\[mine]'. + +An optional prefix argument specifies the number of mines to be hidden +in the field. If no prefix argument is given, a percentage +`mine-mines-%' of the field will contain mines. + +What is Mine?\\ + +Mine is a classical game of hide and seek played on a rectangular grid +containing `mine-xmax' by `mine-ymax' squares (the mine field). + +Your opponent (Emacs, in this case) has hidden several mines within +this field. The object of the game is to find every hidden mine. + +When you're sure a square does NOT contain a mine, you can hit it: +move the mouse over the square and press `\\[mine-mouse-hit]' or +move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. + +If the square is a mine, you loose. +If the square isn't a mine, a number appears which represents +the number of mines in the surrounding eight squares. + +When you think a square DOES contain a mine, you can mark it: +move the mouse over the square and press `\\[mine-mouse-mark]' or +move the cursor with the usual keys and press `\\[mine-mark-curpoint]'. + +The number of hidden mines remaining in the mine field is indicated +inside the buffer. Every time you mark a square as a mine, this +number decreases by one, even if you incorrectly mark a square. + +If `mine-torus' is non-nil (the default), the Mine game is played over +a periodic field (like a torus). Each mine is hidden periodically +over the mine board `mine-nb-tiles-x' times in the x direction and +`mine-nb-tiles-y' times in the y direction. + +If `mine-colorp' is non-nil (the default, if the system allows it), +the game is displayed with colors. The colors can be chosen with the +variable `mine-colors'. + +If the redisplay is not fast enough, increase `mine-level'. If you +want to see a smoother (slower) redisplay, decrease `mine-level', +`mine-count1-max' and `mine-count2-max'. + +You can get help on `mine-mode' and its key bindings by pressing `\\[mine-help]' +while in the *Mine* buffer. +" t nil) + +(autoload 'mine-version "mine" "\ +Return string describing the current version of Mine. +When called interactively, displays the version." t nil) + +(autoload 'mine-help "mine" "\ +*Get help on `mine-mode'." t nil) + +;;;*** + ;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el") (autoload 'mpuz "mpuz" "\ @@ -1912,10 +2002,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) @@ -1925,10 +2025,32 @@ ;;;*** -;;;### (autoloads (gnus-sound-play) "gnus-sound" "gnus/gnus-sound.el") - -(autoload 'gnus-sound-play "gnus-sound" "\ -Play a sound through the speaker." t nil) +;;;### (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) ;;;*** @@ -1946,14 +2068,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) @@ -1977,193 +2117,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 `message-output' which saves in Unix\nmailbox format." :type '(radio (function-item message-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. @@ -2172,10 +2150,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). @@ -2183,7 +2161,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) @@ -2194,9 +2173,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) @@ -2247,6 +2229,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" "\ @@ -2337,6 +2337,43 @@ ;;;*** +;;;### (autoloads (tmpl-insert-template-file tmpl-insert-template-file-from-fixed-dirs tmpl-expand-templates-in-buffer tmpl-expand-templates-in-region) "tmpl-minor-mode" "hm--html-menus/tmpl-minor-mode.el") + +(autoload 'tmpl-expand-templates-in-region "tmpl-minor-mode" "\ +Expand the templates in the region from BEGIN to END. +If BEGIN and and are nil, then the current region is used." t nil) + +(autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" "\ +Expand all templates in the current buffer." t nil) + +(autoload 'tmpl-insert-template-file-from-fixed-dirs "tmpl-minor-mode" "\ +Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. +This command tries to read the template file from a list of +predefined directries (look at `tmpl-template-dir-list') and it filters +the contents of this directories with the regular expression +`tmpl-filter-regexp' (look also at this variable). +The command uses a history variable, which could be changed with the +variable `tmpl-history-variable-name'. + +The user of the command is able to change interactive to another +directory by entering at first the string \"Change the directory\". +This maybe to difficult for the user. Therefore another command +called `tmpl-insert-template-file' exist, which doesn't use fixed +directories and filters." t nil) + +(autoload 'tmpl-insert-template-file "tmpl-minor-mode" "\ +Insert a template FILE and expand it, if `tmpl-automatic-expand' is t. +Look also at `tmpl-template-dir-list', to specify a default template directory. +You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' +which has additional advantages (and disadvantages :-). + +ATTENTION: The interface of this function has changed. The old +function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). +The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must +now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." t nil) + +;;;*** + ;;;### (autoloads (hmail:compose) "hmail" "hyperbole/hmail.el") (autoload 'hmail:compose "hmail" "\ @@ -3659,7 +3696,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.7 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.8 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4952,11 +4989,66 @@ ;;;*** +;;;### (autoloads (verilog-mode) "verilog-mode" "modes/verilog-mode.el") + +(autoload 'verilog-mode "verilog-mode" "\ +Major mode for editing Verilog code. \\ +NEWLINE, TAB indents for Verilog code. +Delete converts tabs to spaces as it moves back. +Supports highlighting. + +Variables controlling indentation/edit style: + + verilog-indent-level (default 3) + Indentation of Verilog statements with respect to containing block. + verilog-cexp-indent (default 1) + Indentation of Verilog statements broken across lines. + verilog-case-indent (default 2) + Indentation for case statements. + verilog-auto-newline (default nil) + Non-nil means automatically newline after simcolons and the punctation mark + after an end. + verilog-auto-indent-on-newline (default t) + Non-nil means automatically indent line after newline + verilog-tab-always-indent (default t) + Non-nil means TAB in Verilog mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + verilog-indent-begin-after-if (default t) + Non-nil means to indent begin statements following a preceeding + if, else, while, for and repeat statements, if any. otherwise, + the begin is lined up with the preceeding token. If t, you get: + if (a) + begin + otherwise you get: + if (a) + begin + verilog-auto-endcomments (default t) + Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. + The type and name of the object will be set between the braces. + verilog-auto-lineup (default `(all)) + List of contexts where auto lineup of :'s or ='s should be done. + +Turning on Verilog mode calls the value of the variable verilog-mode-hook with +no args, if that value is non-nil. +Other useful functions are: +\\[verilog-complete-word] -complete word with appropriate possibilities (functions, verilog keywords...) +\\[verilog-comment-area] - Put marked area in a comment, fixing nested comments. +\\[verilog-uncomment-area] - Uncomment an area commented with \\[verilog-comment-area]. +\\[verilog-insert-block] - insert begin ... end; +\\[verilog-star-comment] - insert /* ... */ +\\[verilog-mark-defun] - Mark function. +\\[verilog-beg-of-defun] - Move to beginning of current function. +\\[verilog-end-of-defun] - Move to end of current function. +\\[verilog-label-be] - Label matching begin ... end, fork ... join and case ... endcase statements; +" t nil) + +;;;*** + ;;;### (autoloads (vhdl-mode) "vhdl-mode" "modes/vhdl-mode.el") (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.7 $ +vhdl-mode $Revision: 1.8 $ 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 @@ -6072,9 +6164,7 @@ Various methods of control are provided for the Font Lock cache. In general, see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', -`fast-lock-save-others' and `fast-lock-save-faces'. - -Use \\[fast-lock-submit-bug-report] to send bug reports or feedback." t nil) +`fast-lock-save-others' and `fast-lock-save-faces'." t nil) (autoload 'turn-on-fast-lock "fast-lock" "\ Unconditionally turn on Fast Lock mode." nil nil) @@ -7530,6 +7620,20 @@ ;;;*** +;;;### (autoloads (webjump) "webjump" "packages/webjump.el") + +(autoload 'webjump "webjump" "\ +Jumps to a Web site from a programmable hotlist. + +See the documentation for the `webjump-sites' variable for how to customize the +hotlist. + +Feedback on WebJump can be sent to the author, Neil W. Van Dyke , +or submitted via `\\[webjump-submit-bug-report]'. The latest version can be +gotten from `http://www.cs.brown.edu/people/nwv/'." t nil) + +;;;*** + ;;;### (autoloads (webster-spell webster-endings webster) "webster" "packages/webster.el") (autoload 'webster "webster" "\ @@ -7709,7 +7813,7 @@ ;;;*** -;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query insert-kbd-macro name-last-kbd-macro) "macros" "prim/macros.el") +;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query name-last-kbd-macro) "macros" "prim/macros.el") (autoload 'name-last-kbd-macro "macros" "\ Assign a name to the last keyboard macro defined. @@ -7718,20 +7822,6 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command." t nil) -(autoload 'insert-kbd-macro "macros" "\ -Insert in buffer the definition of kbd macro NAME, as Lisp code. -Optional second argument KEYS means also record the keys it is on -\(this is the prefix argument, when calling interactively). - -This Lisp code will, when executed, define the kbd macro with the -same definition it has now. If you say to record the keys, -the Lisp code will also rebind those keys to the macro. -Only global key bindings are recorded since executing this Lisp code -always makes global bindings. - -To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', -use this command, and then save the file." t nil) - (autoload 'kbd-macro-query "macros" "\ Query user during kbd macro execution. With prefix argument, enters recursive edit, @@ -8029,9 +8119,11 @@ (autoload 'load-sound-file "sound" "\ Read in an audio-file and add it to the sound-alist. -You can only play sound files if you are running on display 0 of the console -of a Sun SparcStation, SGI machine, or HP9000s700, or running a NetAudio -server. The sound file must be in the Sun/NeXT U-LAW format." t nil) +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +The sound file must be in the Sun/NeXT U-LAW format." t nil) (autoload 'load-default-sounds "sound" "\ Load and install some sound files as beep-types. @@ -8719,6 +8811,93 @@ ;;;*** +;;;### (autoloads (insert-kbd-macro format-kbd-macro read-kbd-macro edit-named-kbd-macro edit-last-kbd-macro edit-kbd-macro) "edmacro" "utils/edmacro.el") + +(define-key ctl-x-map "\C-k" 'edit-kbd-macro) + +(defvar edmacro-eight-bits nil "\ +*Non-nil if edit-kbd-macro should leave 8-bit characters intact. +Default nil means to write characters above \\177 in octal notation.") + +(autoload 'edit-kbd-macro "edmacro" "\ +Edit a keyboard macro. +At the prompt, type any key sequence which is bound to a keyboard macro. +Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit +the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by +its command name. +With a prefix argument, format the macro in a more concise way." t nil) + +(autoload 'edit-last-kbd-macro "edmacro" "\ +Edit the most recently defined keyboard macro." t nil) + +(autoload 'edit-named-kbd-macro "edmacro" "\ +Edit a keyboard macro which has been given a name by `name-last-kbd-macro'." t nil) + +(autoload 'read-kbd-macro "edmacro" "\ +Read the region as a keyboard macro definition. +The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\". +See documentation for `edmacro-mode' for details. +Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored. +The resulting macro is installed as the \"current\" keyboard macro. + +In Lisp, may also be called with a single STRING argument in which case +the result is returned rather than being installed as the current macro. +The result will be a string if possible, otherwise an event vector. +Second argument NEED-VECTOR means to return an event vector always." t nil) + +(autoload 'format-kbd-macro "edmacro" "\ +Return the keyboard macro MACRO as a human-readable string. +This string is suitable for passing to `read-kbd-macro'. +Second argument VERBOSE means to put one command per line with comments. +If VERBOSE is `1', put everything on one line. If VERBOSE is omitted +or nil, use a compact 80-column format." nil nil) + +(autoload 'insert-kbd-macro "edmacro" "\ +Insert in buffer the definition of kbd macro NAME, as Lisp code. +Optional second arg KEYS means also record the keys it is on +\(this is the prefix argument, when calling interactively). + +This Lisp code will, when executed, define the kbd macro with the same +definition it has now. If you say to record the keys, the Lisp code +will also rebind those keys to the macro. Only global key bindings +are recorded since executing this Lisp code always makes global +bindings. + +To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +use this command, and then save the file." t nil) + +;;;*** + +;;;### (autoloads (turn-on-eldoc-mode eldoc-mode) "eldoc" "utils/eldoc.el") + +(defvar eldoc-mode nil "\ +*If non-nil, show the defined parameters for the elisp function near point. + +For the emacs lisp function at the beginning of the sexp which point is +within, show the defined parameters for the function in the echo area. +This information is extracted directly from the function or macro if it is +in pure lisp. If the emacs function is a subr, the parameters are obtained +from the documentation string if possible. + +If point is over a documented variable, print that variable's docstring +instead. + +This variable is buffer-local.") + +(autoload 'eldoc-mode "eldoc" "\ +*Enable or disable eldoc mode. +See documentation for the variable of the same name for more details. + +If called interactively with no prefix argument, toggle current condition +of the mode. +If called with a positive or negative prefix argument, enable or disable +the mode, respectively." t nil) + +(autoload 'turn-on-eldoc-mode "eldoc" "\ +Unequivocally turn on eldoc-mode (see variable documentation)." t nil) + +;;;*** + ;;;### (autoloads (elp-submit-bug-report elp-results elp-instrument-package elp-instrument-list elp-restore-function elp-instrument-function) "elp" "utils/elp.el") (autoload 'elp-instrument-function "elp" "\ @@ -8850,6 +9029,33 @@ ;;;*** +;;;### (autoloads (floating-toolbar-from-extent-or-popup-mode-menu floating-toolbar-or-popup-mode-menu floating-toolbar) "floating-toolbar" "utils/floating-toolbar.el") + +(autoload 'floating-toolbar "floating-toolbar" "\ +Popup a toolbar near the current mouse position. +The toolbar instantiator used is taken from the 'floating-toolbar +property of any extent under the mouse. If no such non-nil +property exists for any extent under the mouse, then the value of the +variable `floating-toolbar' is checked. If its value si nil, then +no toolbar will be displayed. + +This command should be bound to a button press event. + +When called from a program, first arg EVENT should be the button +press event. Optional second arg EXTENT-LOCAL-ONLY specifies +that only extent local toolbars should be used; this means the +`floating-toolbar' variable will not be consulted." t nil) + +(autoload 'floating-toolbar-or-popup-mode-menu "floating-toolbar" "\ +Like floating-toolbar, but if no toolbar is displayed +run popup-mode-menu." t nil) + +(autoload 'floating-toolbar-from-extent-or-popup-mode-menu "floating-toolbar" "\ +Like floating-toolbar-or-popup-mode-menu, but search only for an +extent local toolbar." t nil) + +;;;*** + ;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl" "utils/flow-ctrl.el") (autoload 'enable-flow-control "flow-ctrl" "\ @@ -9495,16 +9701,12 @@ (autoload 'w3-open-local "w3" "\ Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." t nil) +hypertext document." t nil) (autoload 'w3-find-file "w3" "\ Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." t nil) +hypertext document." t nil) (autoload 'w3-fetch-other-frame "w3" "\ Attempt to follow the hypertext reference under point in a new frame. @@ -9575,36 +9777,6 @@ ;;;*** -;;;### (autoloads (widget-delete widget-create) "widget-edit" "w3/widget-edit.el") - -(autoload 'widget-create "widget-edit" "\ -Create widget of TYPE. -The optional ARGS are additional keyword arguments." nil nil) - -(autoload 'widget-delete "widget-edit" "\ -Delete WIDGET." nil nil) - -;;;*** - -;;;### (autoloads (define-widget) "widget" "w3/widget.el") - -(autoload 'define-widget "widget" "\ -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." nil nil) - -;;;*** - ;;;### (autoloads (font-menu-weight-constructor font-menu-size-constructor font-menu-family-constructor reset-device-font-menus) "x-font-menu" "x11/x-font-menu.el") (defvar font-menu-ignore-scaled-fonts t "\ diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/files.el --- a/lisp/prim/files.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 09:13:56 2007 +0200 @@ -2577,7 +2577,10 @@ files (buffer (get-buffer-create " *recover*"))) ;; #### dired-do-flagged-delete in FSF. - (dired-do-deletions t) + ;; This version is for ange-ftp + ;;(dired-do-deletions t) + ;T This version is for efs + (dired-expunge-deletions) (unwind-protect (save-excursion ;; Read in the auto-save-list file. @@ -2936,4 +2939,13 @@ filename (error "Apparently circular symlink path")))) +;; Suggested by Michael Kifer +(defun file-remote-p (file) + "Test whether file resides on the local system. +The special value 'unknown is returned if no remote file access package +has been loaded." + (cond ((fboundp 'efs-ftp-path) (efs-ftp-path name)) + ((fboundp 'ange-ftp-ftp-name) (ange-ftp-ftp-name name)) + (t 'unknown))) + ;;; files.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/frame.el --- a/lisp/prim/frame.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 09:13:56 2007 +0200 @@ -1022,6 +1022,9 @@ (append (list save-frame) frames) frames))) +(defvar temp-buffer-shrink-to-fit t + "*When non-nil resize temporary output buffers to minimize blank lines.") + (defun show-temp-buffer-in-current-frame (buffer) "For use as the value of temp-buffer-show-function: always displays the buffer in the current frame, regardless of the behavior @@ -1035,7 +1038,8 @@ (setq minibuffer-scroll-window window) (set-window-start window 1) ; obeys narrowing (set-window-point window 1) - (shrink-window-if-larger-than-buffer window) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer window)) nil))) (setq pre-display-buffer-function 'get-frame-for-buffer) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/glyphs.el --- a/lisp/prim/glyphs.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/glyphs.el Mon Aug 13 09:13:56 2007 +0200 @@ -599,13 +599,15 @@ ,@(if (featurep 'xpm) '(("^/\\* XPM \\*/" [xpm :data nil] 2))) ,@(if (featurep 'xface) '(("^X-Face:" [xface :data nil] 2))) ,@(if (featurep 'gif) '(("\.gif$" [gif :file nil] 2))) - ,@(if (featurep 'gif) '(("^GIF87" [gif :data nil] 2))) + ,@(if (featurep 'gif) '(("^GIF8[79]" [gif :data nil] 2))) ,@(if (featurep 'jpeg) '(("\.jpeg$" [jpeg :file nil] 2))) ,@(if (featurep 'jpeg) '(("\.jpg$" [jpeg :file nil] 2))) ;; all of the JFIF-format JPEG's that I've seen begin with ;; the following. I have no idea if this is standard. ,@(if (featurep 'jpeg) '(("^\377\330\340\000\020JFIF" [jpeg :data nil] 2))) + ,@(if (featurep 'png) '(("\.png$" [png :file nil] 2))) + ,@(if (featurep 'png) '(("^\211PNG" [png :data nil] 2))) ("" [autodetect :data nil] 2)))) ;; #### this should really be formatted-string, not string but we ;; don't have it implemented yet diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 09:13:56 2007 +0200 @@ -45,10 +45,7 @@ ;; global-map definitions moved to keydefs.el (fset 'help-command help-map) -(let ((ch help-char)) - (if (or (characterp ch) (integerp ch)) - (setq ch (char-to-string ch))) - (define-key help-map ch 'help-for-help)) +(define-key help-map (vector help-char) 'help-for-help) (define-key help-map "?" 'help-for-help) (define-key help-map 'help 'help-for-help) @@ -382,7 +379,8 @@ (t (message (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help.")))) - (shrink-window-if-larger-than-buffer helpwin))))))) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer helpwin)))))))) (defun describe-key (key) "Display documentation of the function invoked by KEY. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/keydefs.el --- a/lisp/prim/keydefs.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/keydefs.el Mon Aug 13 09:13:56 2007 +0200 @@ -142,10 +142,7 @@ ;; FSFmacs help.el -(let ((ch help-char)) - (if (or (characterp ch) (integerp ch)) - (setq ch (char-to-string ch))) - (define-key global-map ch 'help-command)) +(define-key global-map (vector help-char) 'help-command) (define-key global-map 'help 'help-command) (define-key global-map 'f1 'help-command) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/lisp.el --- a/lisp/prim/lisp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/lisp.el Mon Aug 13 09:13:56 2007 +0200 @@ -327,8 +327,9 @@ (setq list (nreverse new)))) (with-output-to-temp-buffer "*Completions*" (display-completion-list list)) - (shrink-window-if-larger-than-buffer - (get-buffer-window "*Completions*"))) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Completions*")))) (message "Making completion list...%s" "done"))))) ;;; lisp.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/loadup.el --- a/lisp/prim/loadup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/loadup.el Mon Aug 13 09:13:56 2007 +0200 @@ -108,6 +108,9 @@ ;; After fixing, eos/loaddefs-eos and loaddefs appear identical?!! ;; So just make loaddefs-eos go away... ;;(load-gc (if (featurep 'sparcworks) "eos/loaddefs-eos" "loaddefs")) + (load-gc "font") ; required by widget + (load-gc "widget") + (load-gc "custom") ; Before loaddefs so that defcustom exists (load-gc "loaddefs") (load-gc "misc") (load-gc "profile") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/macros.el --- a/lisp/prim/macros.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/macros.el Mon Aug 13 09:13:56 2007 +0200 @@ -31,6 +31,8 @@ ;; lisp corresponding to a macro, query the user from within a macro, ;; or apply a macro to each line in the reason. +;; This file is largely superseded by edmacro.el as of XEmacs 20.1. -sb + ;;; Code: ;;;###autoload @@ -50,91 +52,91 @@ symbol)) (fset symbol last-kbd-macro)) -(defun insert-kbd-macro-pretty-string (string) - ;; Convert control characters to the traditional readable representation: - ;; put the four characters \M-x in the buffer instead of the one char \370, - ;; which would deceptively print as `oslash' with the default settings. - (save-restriction - (narrow-to-region (point) (point)) - (prin1 string (current-buffer)) - (goto-char (1+ (point-min))) - (while (not (eobp)) - (cond ((= (following-char) 0) (insert "\\C-@") (delete-char 1)) - ((= (following-char) ?\n) (insert "\\n") (delete-char 1)) - ((= (following-char) ?\r) (insert "\\r") (delete-char 1)) - ((= (following-char) ?\t) (insert "\\t") (delete-char 1)) - ((= (following-char) ?\e) (insert "\\e") (delete-char 1)) - ((= (following-char) 127) (insert "\\C-?") (delete-char 1)) - ((= (following-char) 128) (insert "\\M-\\C-@") (delete-char 1)) - ((= (following-char) 255) (insert "\\M-\\C-?") (delete-char 1)) - ((and (> (following-char) 127) (< (following-char) 155)) - (insert "\\M-\\C-") - (insert (- (following-char) 32)) - (delete-char 1) - (forward-char -1)) - ((and (>= (following-char) 155) (< (following-char) 160)) - (insert "\\M-\\C-") - (insert (- (following-char) 64)) - (delete-char 1) - (forward-char -1)) - ((>= (following-char) 160) - (insert "\\M-") - (insert (- (following-char) 128)) - (delete-char 1) - (forward-char -1)) - ((< (following-char) 27) - ;;(insert "\\^") (insert (+ (following-char) 64)) - (insert "\\C-") (insert (+ (following-char) 96)) - (delete-char 1) - (forward-char -1)) - ((< (following-char) 32) - ;;(insert "\\^") (insert (+ (following-char) 64)) - (insert "\\C-") (insert (+ (following-char) 64)) - (delete-char 1) - (forward-char -1)) - (t - (forward-char 1)))))) +;(defun insert-kbd-macro-pretty-string (string) +; ;; Convert control characters to the traditional readable representation: +; ;; put the four characters \M-x in the buffer instead of the one char \370, +; ;; which would deceptively print as `oslash' with the default settings. +; (save-restriction +; (narrow-to-region (point) (point)) +; (prin1 string (current-buffer)) +; (goto-char (1+ (point-min))) +; (while (not (eobp)) +; (cond ((= (following-char) 0) (insert "\\C-@") (delete-char 1)) +; ((= (following-char) ?\n) (insert "\\n") (delete-char 1)) +; ((= (following-char) ?\r) (insert "\\r") (delete-char 1)) +; ((= (following-char) ?\t) (insert "\\t") (delete-char 1)) +; ((= (following-char) ?\e) (insert "\\e") (delete-char 1)) +; ((= (following-char) 127) (insert "\\C-?") (delete-char 1)) +; ((= (following-char) 128) (insert "\\M-\\C-@") (delete-char 1)) +; ((= (following-char) 255) (insert "\\M-\\C-?") (delete-char 1)) +; ((and (> (following-char) 127) (< (following-char) 155)) +; (insert "\\M-\\C-") +; (insert (- (following-char) 32)) +; (delete-char 1) +; (forward-char -1)) +; ((and (>= (following-char) 155) (< (following-char) 160)) +; (insert "\\M-\\C-") +; (insert (- (following-char) 64)) +; (delete-char 1) +; (forward-char -1)) +; ((>= (following-char) 160) +; (insert "\\M-") +; (insert (- (following-char) 128)) +; (delete-char 1) +; (forward-char -1)) +; ((< (following-char) 27) +; ;;(insert "\\^") (insert (+ (following-char) 64)) +; (insert "\\C-") (insert (+ (following-char) 96)) +; (delete-char 1) +; (forward-char -1)) +; ((< (following-char) 32) +; ;;(insert "\\^") (insert (+ (following-char) 64)) +; (insert "\\C-") (insert (+ (following-char) 64)) +; (delete-char 1) +; (forward-char -1)) +; (t +; (forward-char 1)))))) -;;;###autoload -(defun insert-kbd-macro (macroname &optional keys) - "Insert in buffer the definition of kbd macro NAME, as Lisp code. -Optional second argument KEYS means also record the keys it is on -\(this is the prefix argument, when calling interactively). +;; ;;;###autoload +;(defun insert-kbd-macro (macroname &optional keys) +; "Insert in buffer the definition of kbd macro NAME, as Lisp code. +;Optional second argument KEYS means also record the keys it is on +;\(this is the prefix argument, when calling interactively). -This Lisp code will, when executed, define the kbd macro with the -same definition it has now. If you say to record the keys, -the Lisp code will also rebind those keys to the macro. -Only global key bindings are recorded since executing this Lisp code -always makes global bindings. +;This Lisp code will, when executed, define the kbd macro with the +;same definition it has now. If you say to record the keys, +;the Lisp code will also rebind those keys to the macro. +;Only global key bindings are recorded since executing this Lisp code +;always makes global bindings. -To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', -use this command, and then save the file." - (interactive "CInsert kbd macro (name): \nP") - (let (definition) - (if (string= (symbol-name macroname) "") - (progn - (setq macroname 'last-kbd-macro - definition last-kbd-macro) - (insert "(setq ")) - (progn - (setq definition (symbol-function macroname)) - (insert "(fset '"))) - (prin1 macroname (current-buffer)) - (insert "\n ") - (let ((string (events-to-keys definition t))) - (if (stringp string) - (insert-kbd-macro-pretty-string string) - (prin1 string (current-buffer)))) - (insert ")\n") - (if keys - (let ((keys (where-is-internal macroname))) - (while keys - (insert "(global-set-key ") - (prin1 (car keys) (current-buffer)) - (insert " '") - (prin1 macroname (current-buffer)) - (insert ")\n") - (setq keys (cdr keys))))))) +;To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +;use this command, and then save the file." +; (interactive "CInsert kbd macro (name): \nP") +; (let (definition) +; (if (string= (symbol-name macroname) "") +; (progn +; (setq macroname 'last-kbd-macro +; definition last-kbd-macro) +; (insert "(setq ")) +; (progn +; (setq definition (symbol-function macroname)) +; (insert "(fset '"))) +; (prin1 macroname (current-buffer)) +; (insert "\n ") +; (let ((string (events-to-keys definition t))) +; (if (stringp string) +; (insert-kbd-macro-pretty-string string) +; (prin1 string (current-buffer)))) +; (insert ")\n") +; (if keys +; (let ((keys (where-is-internal macroname))) +; (while keys +; (insert "(global-set-key ") +; (prin1 (car keys) (current-buffer)) +; (insert " '") +; (prin1 macroname (current-buffer)) +; (insert ")\n") +; (setq keys (cdr keys))))))) ;;;###autoload (defun kbd-macro-query (flag) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/modeline.el --- a/lisp/prim/modeline.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/modeline.el Mon Aug 13 09:13:56 2007 +0200 @@ -394,7 +394,7 @@ (defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map) "Keymap consulted for mouse-clicks on the modeline-modified string.") (define-key modeline-modified-map 'button2 - (make-modeline-command-wrapper 'toggle-read-only)) + (make-modeline-command-wrapper 'vc-toggle-read-only)) (defvar modeline-modified-extent (make-extent nil nil) "Extent covering the modeline-modified string.") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/obsolete.el --- a/lisp/prim/obsolete.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/obsolete.el Mon Aug 13 09:13:56 2007 +0200 @@ -38,6 +38,13 @@ (define-function oldfun newfun) (make-obsolete oldfun newfun)) +(defsubst define-compatible-function-alias (oldfun newfun) + "Define OLDFUN as a compatible alias for function NEWFUN. +This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN +as provided for compatibility only." + (define-function oldfun newfun) + (make-compatible oldfun newfun)) + (defsubst define-obsolete-variable-alias (oldvar newvar) "Define OLDVAR as an obsolete alias for varction NEWVAR. This makes referencing or setting OLDVAR equivalent to referencing or @@ -45,6 +52,13 @@ (defvaralias oldvar newvar) (make-obsolete-variable oldvar newvar)) +(defsubst define-compatible-variable-alias (oldvar newvar) + "Define OLDVAR as a compatible alias for varction NEWVAR. +This makes referencing or setting OLDVAR equivalent to referencing or +setting NEWVAR and marks OLDVAR as provided for compatibility only." + (defvaralias oldvar newvar) + (make-compatible-variable oldvar newvar)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;; device stuff (make-obsolete-variable 'window-system "use (console-type)") @@ -54,24 +68,24 @@ (defun x-display-color-p (&optional device) "Returns non-nil if DEVICE is a color device." (eq 'color (device-class device))) -(make-obsolete 'x-display-color-p 'device-class) +(make-compatible 'x-display-color-p 'device-class) (define-function 'x-color-display-p 'x-display-color-p) -(make-obsolete 'x-display-color-p 'device-class) +(make-compatible 'x-display-color-p 'device-class) (defun x-display-grayscale-p (&optional device) "Returns non-nil if DEVICE is a grayscale device." (eq 'grayscale (device-class device))) -(make-obsolete 'x-display-grayscale-p 'device-class) +(make-compatible 'x-display-grayscale-p 'device-class) (define-function 'x-grayscale-display-p 'x-display-grayscale-p) -(make-obsolete 'x-display-grayscale-p 'device-class) +(make-compatible 'x-display-grayscale-p 'device-class) -(define-obsolete-function-alias 'x-display-pixel-width 'device-pixel-width) -(define-obsolete-function-alias 'x-display-pixel-height +(define-compatible-function-alias 'x-display-pixel-width 'device-pixel-width) +(define-compatible-function-alias 'x-display-pixel-height 'device-pixel-height) -(define-obsolete-function-alias 'x-display-planes 'device-bitplanes) -(define-obsolete-function-alias 'x-display-color-cells 'device-color-cells) +(define-compatible-function-alias 'x-display-planes 'device-bitplanes) +(define-compatible-function-alias 'x-display-color-cells 'device-color-cells) (define-obsolete-function-alias 'baud-rate 'device-baud-rate) @@ -246,7 +260,7 @@ (define-obsolete-variable-alias 'default-tty-frame-alist 'default-tty-frame-plist) -(make-obsolete 'frame-parameters 'frame-property) +(make-compatible 'frame-parameters 'frame-property) (defun frame-parameters (&optional frame) "Return the parameters-alist of frame FRAME. It is a list of elements of the form (PARM . VALUE), where PARM is a symbol. @@ -265,7 +279,7 @@ ;; future. (destructive-plist-to-alist (frame-properties frame))) -(make-obsolete 'modify-frame-parameters 'set-frame-properties) +(make-compatible 'modify-frame-parameters 'set-frame-properties) (defun modify-frame-parameters (frame alist) "Modify the properties of frame FRAME according to ALIST. ALIST is an alist of properties to change and their new values. @@ -308,7 +322,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;; insertion and deletion (define-obsolete-function-alias 'insert-and-inherit 'insert) -(define-obsolete-function-alias 'insert-before-markers-and-inerhit +(define-obsolete-function-alias 'insert-before-markers-and-inherit 'insert-before-markers) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; keymaps @@ -380,20 +394,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;; modeline -(define-obsolete-function-alias 'redraw-mode-line 'redraw-modeline) -(define-obsolete-function-alias 'force-mode-line-update +(define-compatible-function-alias 'redraw-mode-line 'redraw-modeline) +(define-compatible-function-alias 'force-mode-line-update 'redraw-modeline) ;; FSF compatibility -(define-obsolete-variable-alias 'mode-line-map 'modeline-map) -(define-obsolete-variable-alias 'mode-line-buffer-identification +(define-compatible-variable-alias 'mode-line-map 'modeline-map) +(define-compatible-variable-alias 'mode-line-buffer-identification 'modeline-buffer-identification) -(define-obsolete-variable-alias 'mode-line-process 'modeline-process) -(define-obsolete-variable-alias 'mode-line-modified 'modeline-modified) -(make-obsolete-variable 'mode-line-inverse-video +(define-compatible-variable-alias 'mode-line-process 'modeline-process) +(define-compatible-variable-alias 'mode-line-modified 'modeline-modified) +(make-compatible-variable 'mode-line-inverse-video "use set-face-highlight-p and set-face-reverse-p") -(define-obsolete-variable-alias 'default-mode-line-format +(define-compatible-variable-alias 'default-mode-line-format 'default-modeline-format) -(define-obsolete-variable-alias 'mode-line-format 'modeline-format) -(define-obsolete-variable-alias 'mode-line-menu 'modeline-menu) +(define-compatible-variable-alias 'mode-line-format 'modeline-format) +(define-compatible-variable-alias 'mode-line-menu 'modeline-menu) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; mouse diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/overlay.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/prim/overlay.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,210 @@ +;;; overlay.el --- overlay support. + +;;;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs +;; Keywords: internal + +;; 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 +;; 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. + +;; 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. + +;;; Synched up with: Not in FSF. + +(defun overlayp (object) + "Return t if OBJECT is an overlay." + (and (extentp object) + (extent-property object 'overlay))) + +(defun make-overlay (beg end &optional buffer front-advance rear-advance) + "Create a new overlay with range BEG to END in BUFFER. +If omitted, BUFFER defaults to the current buffer. +BEG and END may be integers or markers. +The fourth arg FRONT-ADVANCE, if non-nil, makes the +front delimiter advance when text is inserted there. +The fifth arg REAR-ADVANCE, if non-nil, makes the +rear delimiter advance when text is inserted there." + (let (overlay temp) + (if (null buffer) + (setq buffer (current-buffer)) + (check-argument-type 'bufferp buffer)) + + (if (> beg end) + (setq temp beg + beg end + end temp)) + + (setq overlay (make-extent beg end buffer)) + (set-extent-property overlay 'overlay t) + + (if front-advance + (set-extent-property overlay 'start-open t) + (set-extent-property overlay 'start-closed t)) + + (if rear-advance + (set-extent-property overlay 'end-closed t) + (set-extent-property overlay 'end-open t)) + + overlay)) + +(defun move-overlay (overlay beg end &optional buffer) + "Set the endpoints of OVERLAY to BEG and END in BUFFER. +If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now. +If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current +buffer." + (let (temp) + (check-argument-type 'overlayp overlay) + (if (null buffer) + (setq buffer (extent-object overlay))) + + (if (null buffer) + (setq buffer (current-buffer))) + + (check-argument-type 'bufferp buffer) + + (if (and (= beg end) + (not (null (extent-property overlay 'evaporate)))) + (delete-overlay overlay) + + (if (> beg end) + (setq temp beg + beg end + end temp)) + + (set-extent-endpoints overlay beg end buffer) + overlay))) + +(defun delete-overlay (overlay) + "Delete the overlay OVERLAY from its buffer." + (check-argument-type 'overlayp overlay) + (detach-extent overlay) + nil) + +(defun overlay-start (overlay) + "Return the position at which OVERLAY starts." + (check-argument-type 'overlayp overlay) + (extent-start-position overlay)) + +(defun overlay-end (overlay) + "Return the position at which OVERLAY ends." + (check-argument-type 'overlayp overlay) + (extent-end-position overlay)) + +(defun overlay-buffer (overlay) + "Return the buffer OVERLAY belongs to." + (check-argument-type 'overlayp overlay) + (extent-object overlay)) + +(defun overlay-properties (overlay) + "Return a list of the properties on OVERLAY. +This is a copy of OVERLAY's plist; modifying its conses has no effect on +OVERLAY." + (check-argument-type 'overlayp overlay) + (extent-properties overlay)) + +(defun overlays-at (pos) + "Return a list of the overlays that contain position POS." + (overlays-in pos pos)) + +(defun overlays-in (beg end) + "Return a list of the overlays that overlap the region BEG ... END. +Overlap means that at least one character is contained within the overlay +and also contained within the specified region. +Empty overlays are included in the result if they are located at BEG +or between BEG and END." + (let (lst) + (mapcar (function + (lambda (overlay) + (and (extent-property overlay 'overlay) + (setq lst (append lst (list overlay)))))) + (extent-list nil beg end)) + lst)) + +(defun next-overlay-change (pos) + "Return the next position after POS where an overlay starts or ends. +If there are no more overlay boundaries after POS, return (point-max)." + (let ((next (point-max)) + end) + (mapcar (function + (lambda (overlay) + (if (< (setq end (extent-end-position overlay)) next) + (setq next end)))) + (overlays-in pos end)) + next)) + +(defun previous-overlay-change (pos) + "Return the previous position before POS where an overlay starts or ends. +If there are no more overlay boundaries before POS, return (point-min)." + (let ((prev (point-min)) + beg) + (mapcar (function + (lambda (overlay) + (if (and (> (setq beg (extent-start-position overlay)) prev) + (< beg pos)) + (setq prev beg)))) + (overlays-in prev pos)) + prev)) + +(defun overlay-lists () + "Return a pair of lists giving all the overlays of the current buffer. +The car has all the overlays before the overlay center; +the cdr has all the overlays after the overlay center. +Recentering overlays moves overlays between these lists. +The lists you get are copies, so that changing them has no effect. +However, the overlays you get are the real objects that the buffer uses." + (if (not (boundp 'xemacs-internal-overlay-center-pos)) + (overlay-recenter (/ (- (point-max) (point-min)) 2))) + (let ((pos xemacs-internal-overlay-center-pos) + before after) + (mapcar + (function + (lambda (overlay) + (if (extent-property overlay 'overlay) + (if (> pos (extent-end-position overlay)) + (setq before (append before (list overlay))) + (setq after (append after (list overlay))))))) + (extent-list)) + (list before after))) + +(defun overlay-recenter (pos) + "Recenter the overlays of the current buffer around position POS." + (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos)) + +(defun overlay-get (overlay prop) + "Get the property of overlay OVERLAY with property name PROP." + (check-argument-type 'overlayp overlay) + (extent-property overlay prop)) + +(defun overlay-put (overlay prop value) + "Set one property of overlay OVERLAY: give property PROP value VALUE." + (check-argument-type 'overlayp overlay) + (cond ((eq prop 'evaporate) + (set-extent-property overlay 'detachable value)) + ((eq prop 'before-string) + (set-extent-property overlay 'begin-glyph + (make-glyph (vector 'string :data value)))) + ((eq prop 'after-string) + (set-extent-property overlay 'end-glyph + (make-glyph (vector 'string :data value)))) + ((memq prop '(window insert-in-front-hooks insert-behind-hooks + modification-hooks)) + (error "cannot support overlay '%s property under XEmacs" + prop))) + (set-extent-property overlay prop value)) + +(provide 'overlay) + +;;; overlay.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 09:13:56 2007 +0200 @@ -1568,9 +1568,12 @@ (goto-char opoint) (line-move arg))) (if (interactive-p) + ;; XEmacs: Not sure what to do about this. It's inconsistent. -sb (condition-case nil (line-move arg) - ((beginning-of-buffer end-of-buffer) (ding nil 'buffer-bound))) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary + (ding nil 'buffer-bound)))) (line-move arg))) nil) @@ -1591,7 +1594,9 @@ (if (interactive-p) (condition-case nil (line-move (- arg)) - ((beginning-of-buffer end-of-buffer) (ding nil 'buffer-bound))) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary ; XEmacs + (ding nil 'buffer-bound)))) (line-move (- arg))) nil) @@ -1614,7 +1619,7 @@ (eval-when-compile (defvar inhibit-point-motion-hooks)) -(defvar line-move-ignore-invisible nil +(defvar line-move-ignore-invisible t "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines. Outline mode sets this.") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/prim/sound.el --- a/lisp/prim/sound.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/prim/sound.el Mon Aug 13 09:13:56 2007 +0200 @@ -31,9 +31,11 @@ (defun load-sound-file (filename sound-name &optional volume) "Read in an audio-file and add it to the sound-alist. -You can only play sound files if you are running on display 0 of the console -of a Sun SparcStation, SGI machine, or HP9000s700, or running a NetAudio -server. The sound file must be in the Sun/NeXT U-LAW format." +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +The sound file must be in the Sun/NeXT U-LAW format." (interactive "fSound file name: \n\ SSymbol to name this sound: \n\ nVolume (0 for default): ") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/sunpro/sunpro-load.el --- a/lisp/sunpro/sunpro-load.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/sunpro/sunpro-load.el Mon Aug 13 09:13:56 2007 +0200 @@ -8,6 +8,4 @@ ;;(load "sunpro-sparcworks") (load "eos/sun-eos-load") (require 'annotations) - (when (featurep 'mule) - (load "mime-setup")) (garbage-collect)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tl/char-table.el --- a/lisp/tl/char-table.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tl/char-table.el Mon Aug 13 09:13:56 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1996,1997 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko -;; Version: $Id: char-table.el,v 1.1 1997/01/30 02:27:29 steve Exp $ +;; Version: $Id: char-table.el,v 1.2 1997/02/15 22:21:24 steve Exp $ ;; Keywords: character, Emacs/mule ;; This file is not part of tl (Tiny Library). @@ -25,13 +25,11 @@ ;;; Code: -(require 'char-util) - (defun char-position-to-string (charset r l &optional plane) (char-to-string (if plane - (make-character charset plane (row-line-to-char r l)) - (make-character charset (row-line-to-char r l)) + (make-char charset plane (+ (* r 16) l)) + (make-char charset (+ (* r 16) l)) ))) (defun char-table-1 (charset r l plane) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tl/emu-x20.el --- a/lisp/tl/emu-x20.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tl/emu-x20.el Mon Aug 13 09:13:56 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1994,1995,1996,1997 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-x20.el,v 1.3 1997/01/30 02:22:46 steve Exp $ +;; Version: $Id: emu-x20.el,v 1.4 1997/02/15 22:21:24 steve Exp $ ;; Keywords: emulation, compatibility, Mule, XEmacs ;; This file is part of XEmacs. @@ -28,12 +28,6 @@ (require 'cyrillic) (require 'emu-xemacs) -(defvar xemacs-beta-version - (if (string-match "(beta\\([0-9]+\\))" emacs-version) - (string-to-number - (substring emacs-version (match-beginning 1)(match-end 1)) - ))) - ;;; @ coding-system ;;; @@ -49,6 +43,7 @@ (defmacro as-binary-process (&rest body) `(let (selective-display ; Disable ^M to nl translation. + (file-coding-system 'no-conversion) process-input-coding-system process-output-coding-system) ,@body)) @@ -57,6 +52,25 @@ `(let ((file-coding-system-for-read 'no-conversion)) ,@body)) +(defmacro as-binary-output-file (&rest body) + `(let ((file-coding-system 'no-conversion)) + ,@body)) + + +;;; @ binary access +;;; + +(defun insert-binary-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally', q.v., but don't code conversion. +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-coding-system-for-read 'no-conversion)) + (insert-file-contents-literally filename visit beg end replace) + )) + ;;; @ MIME charset ;;; @@ -159,25 +173,10 @@ ;;; @ character ;;; -;; (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-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-leading-char 'char-charset) (defun char-category (character) @@ -195,35 +194,10 @@ ;;; @ 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)) - -;;(defalias 'string-width 'string-columns) - (defun string-to-int-list (str) (mapcar #'char-int str) ) -;;(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) -;; ) - ;;; @ end ;;; diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tl/emu.el --- a/lisp/tl/emu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tl/emu.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ ;;; emu.el --- Emulation module for each Emacs variants -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu.el,v 1.3 1997/01/30 02:22:46 steve Exp $ +;; Version: $Id: emu.el,v 1.4 1997/02/15 22:21:25 steve Exp $ ;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs ;; This file is part of emu. @@ -91,22 +91,6 @@ )) -;;; @ binary access -;;; - -(defun insert-binary-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -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. -\[emu.el]" - (as-binary-input-file - (insert-file-contents-literally filename visit beg end replace) - )) - - ;;; @ MIME charset ;;; diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tl/richtext.el --- a/lisp/tl/richtext.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tl/richtext.el Mon Aug 13 09:13:56 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.1.1.2 1996/12/21 20:50:51 steve Exp $ +;; Version: $Id: richtext.el,v 1.2 1997/02/15 22:21:25 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/gnus-art-mime.el --- a/lisp/tm/gnus-art-mime.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/gnus-art-mime.el Mon Aug 13 09:13:56 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.1.1.2 1996/12/21 20:50:48 steve Exp $ +;; $Id: gnus-art-mime.el,v 1.2 1997/02/15 22:21:25 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/gnus-mime.el --- a/lisp/tm/gnus-mime.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/gnus-mime.el Mon Aug 13 09:13:56 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.2 $ +;; Version: $Revision: 1.3 $ ;; 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.2 1996/12/28 21:03:11 steve Exp $") + "$Id: gnus-mime.el,v 1.3 1997/02/15 22:21:26 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/gnus-sum-mime.el --- a/lisp/tm/gnus-sum-mime.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/gnus-sum-mime.el Mon Aug 13 09:13:56 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.2 1996/12/28 21:03:12 steve Exp $ +;; $Id: gnus-sum-mime.el,v 1.3 1997/02/15 22:21:26 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/message-mime.el --- a/lisp/tm/message-mime.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/message-mime.el Mon Aug 13 09:13:56 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 ;; Version: -;; $Id: message-mime.el,v 1.2 1996/12/28 21:03:12 steve Exp $ +;; $Id: message-mime.el,v 1.3 1997/02/15 22:21:26 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/mime-setup.el --- a/lisp/tm/mime-setup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/mime-setup.el Mon Aug 13 09:13:56 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.4 1997/01/30 02:22:47 steve Exp $ +;; $Id: mime-setup.el,v 1.5 1997/02/15 22:21:26 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 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-def.el --- a/lisp/tm/tm-def.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-def.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ ;;; tm-def.el --- definition module for tm -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: tm-def.el,v 1.3 1997/01/30 02:22:47 steve Exp $ +;; Version: $Id: tm-def.el,v 1.4 1997/02/15 22:21:26 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, definition ;; This file is part of tm (Tools for MIME). @@ -170,6 +170,46 @@ )) +;;; @ PGP +;;; + +(defvar pgp-function-alist + '( + ;; for tm-pgp + (verify mc-verify "mc-toplev") + (decrypt mc-decrypt "mc-toplev") + (fetch-key mc-pgp-fetch-key "mc-pgp") + (snarf-keys mc-snarf-keys "mc-toplev") + ;; for tm-edit + (mime-sign tm:mc-pgp-sign-region "tm-edit-mc") + (traditional-sign mc-pgp-sign-region "mc-pgp") + (encrypt tm:mc-pgp-encrypt-region "tm-edit-mc") + (insert-key mc-insert-public-key "mc-toplev") + ) + "Alist of service names vs. corresponding functions and its filenames. +Each element looks like (SERVICE FUNCTION FILE). + +SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', +`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' +or `insert-key'. + +Function is a symbol of function to do specified SERVICE. + +FILE is string of filename which has definition of corresponding +FUNCTION.") + +(defmacro pgp-function (method) + "Return function to do service METHOD." + (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist))))) + ) + +(mapcar (function + (lambda (method) + (autoload (second method)(third method)) + )) + pgp-function-alist) + + ;;; @ definitions about MIME ;;; diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-edit.el --- a/lisp/tm/tm-edit.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-edit.el Mon Aug 13 09:13:56 2007 +0200 @@ -6,7 +6,7 @@ ;; MORIOKA Tomohiko ;; Maintainer: MORIOKA Tomohiko ;; Created: 1994/08/21 renamed from mime.el -;; Version: $Revision: 1.7 $ +;; Version: $Revision: 1.8 $ ;; Keywords: mail, news, MIME, multimedia, multilingual ;; This file is part of tm (Tools for MIME). @@ -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]] -;; [Insert Japanese text here] -;; -;;--[[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.7 1997/02/02 02:16:16 steve Exp $") + "$Id: tm-edit.el,v 1.8 1997/02/15 22:21:28 steve Exp $") (defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) @@ -433,16 +433,6 @@ (defvar mime-editor/encrypting-type 'pgp-elkins "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") -(defvar mime-editor/pgp-sign-function 'tm:mc-pgp-sign-region) -(defvar mime-editor/pgp-encrypt-function 'tm:mc-pgp-encrypt-region) -(defvar mime-editor/traditional-pgp-sign-function 'mc-pgp-sign-region) -(defvar mime-editor/pgp-insert-public-key-function 'mc-insert-public-key) - -(autoload mime-editor/pgp-sign-function "tm-edit-mc") -(autoload mime-editor/pgp-encrypt-function "tm-edit-mc") -(autoload mime-editor/traditional-pgp-sign-function "mc-pgp") -(autoload mime-editor/pgp-insert-public-key-function "mc-toplev") - ;;; @@ about tag ;;; @@ -880,7 +870,7 @@ (defun mime-editor/insert-text () "Insert a text message. -Charset is automatically obtained from the `mime/lc-charset-alist'." +Charset is automatically obtained from the `charsets-mime-charset-alist'." (interactive) (let ((ret (mime-editor/insert-tag "text" nil nil))) (if ret @@ -1558,7 +1548,7 @@ (insert (format "Content-Transfer-Encoding: %s\n" encoding)) ) (insert "\n") - (or (funcall mime-editor/pgp-sign-function + (or (funcall (pgp-function 'mime-sign) (point-min)(point-max) nil nil pgp-boundary) (throw 'mime-editor/error 'pgp-error) ) @@ -1622,7 +1612,7 @@ (insert (format "Content-Transfer-Encoding: %s\n" encoding)) ) (insert "\n") - (or (funcall mime-editor/pgp-encrypt-function + (or (funcall (pgp-function 'encrypt) recipients (point-min) (point-max) from) (throw 'mime-editor/error 'pgp-error) ) @@ -1659,7 +1649,7 @@ ) (insert "\n") (or (as-binary-process - (funcall mime-editor/traditional-pgp-sign-function + (funcall (pgp-function 'traditional-sign) beg (point-max))) (throw 'mime-editor/error 'pgp-error) ) @@ -1693,7 +1683,7 @@ ) (insert "\n") (or (as-binary-process - (funcall mime-editor/pgp-encrypt-function + (funcall (pgp-function 'encrypt) recipients beg (point-max) nil 'maybe) ) (throw 'mime-editor/error 'pgp-error) @@ -2074,7 +2064,7 @@ (interactive "P") (mime-editor/insert-tag "application" "pgp-keys") (mime-editor/define-encoding "7bit") - (funcall mime-editor/pgp-insert-public-key-function) + (funcall (pgp-function 'insert-key)) ) @@ -2444,7 +2434,10 @@ (setq type ctype) ) (cond - ((string-equal type "multipart") + ((string= ctype "application/pgp-signature") + (delete-region (point-min)(point-max)) + ) + ((string= type "multipart") (let* ((boundary (assoc-value "boundary" params)) (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-ew-e.el --- a/lisp/tm/tm-ew-e.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-ew-e.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ ;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Revision: 1.1.1.2 $ +;; Version: $Revision: 1.2 $ ;; Keywords: encoded-word, MIME, multilingual, header, mail, news ;; This file is part of tm (Tools for MIME). @@ -35,7 +35,7 @@ ;;; (defconst tm-ew-e/RCS-ID - "$Id: tm-ew-e.el,v 1.1.1.2 1996/12/21 20:50:44 steve Exp $") + "$Id: tm-ew-e.el,v 1.2 1997/02/15 22:21:29 steve Exp $") (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID)) @@ -316,8 +316,7 @@ ) (t (setq string (car rword)) - (let* ((sl (length string)) - (p 0) np + (let* ((p 0) np (str "") nstr) (while (and (< p len) (progn diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-ftp.el --- a/lisp/tm/tm-ftp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-ftp.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,35 +1,66 @@ -;;; -;;; tm-ftp: anonymous ftp processor for tm-view -;;; -;;; by MASUTANI Yasuhiro (1994/11/ 5) -;;; -;;; modified by MORIOKA Tomohiko (1994/11/ 8) -;;; and OKABE Yasuo (1994/11/11) -;;; -;;; $Id: tm-ftp.el,v 1.2 1996/12/28 21:03:14 steve Exp $ -;;; +;;; tm-ftp.el --- tm-view internal method for anonymous ftp + +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. + +;; Author: MASUTANI Yasuhiro +;; MORIOKA Tomohiko +;; Created: 1994/11/5 +;; Version: $Id: tm-ftp.el,v 1.3 1997/02/15 22:21:29 steve Exp $ +;; Keywords: anonymous ftp, MIME, multimedia, mail, news + +;; This file is part of tm (Tools for MIME). + +;; 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. + +;;; Code: (require 'tm-view) -(require 'ange-ftp) + +(defvar mime-view-ftp-module + (if (< emacs-major-version 19) + 'ange-ftp) + "*Module for ftp file access.") -(defvar mime/dired-function +(and mime-view-ftp-module + (require mime-view-ftp-module) + ) + +(defvar mime-article/dired-function (if mime/use-multi-frame (function dired-other-frame) - (function dired) + (function mime-article/dired-function-for-one-frame) )) -(defun mime/decode-message/external-ftp (beg end cal) - (let ((access-type (cdr (assoc "access-type" cal))) - (site (cdr (assoc "site" cal))) - (directory (cdr (assoc "directory" cal))) - (name (cdr (assoc "name" cal))) - (mode (cdr (assoc "mode" cal))) - (pathname)) - (setq pathname - (concat "/anonymous@" site ":" directory)) - (message (concat "Accessing " pathname "/" name "...")) - (switch-to-buffer mime::article/preview-buffer) - (funcall mime/dired-function pathname) +(defun mime-article/dired-function-for-one-frame (dir) + (let ((win (or (get-buffer-window mime::article/preview-buffer) + (get-largest-window)))) + (select-window win) + (dired dir) + )) + +(defun mime-article/decode-message/external-ftp (beg end cal) + (let* ((access-type (cdr (assoc "access-type" cal))) + (site (cdr (assoc "site" cal))) + (directory (cdr (assoc "directory" cal))) + (name (cdr (assoc "name" cal))) + (mode (cdr (assoc "mode" cal))) + (pathname (concat "/anonymous@" site ":" directory)) + ) + (message (concat "Accessing " (expand-file-name name pathname) "...")) + (funcall mime-article/dired-function pathname) (goto-char (point-min)) (search-forward name) )) @@ -37,7 +68,13 @@ (set-atype 'mime/content-decoding-condition '((type . "message/external-body") ("access-type" . "anon-ftp") - (method . mime/decode-message/external-ftp) + (method . mime-article/decode-message/external-ftp) )) + +;;; @ end +;;; + (provide 'tm-ftp) + +;;; tm-ftp.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-image.el --- a/lisp/tm/tm-image.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-image.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,17 +1,17 @@ ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers -;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko ;; Copyright (C) 1996 Dan Rich ;; Author: MORIOKA Tomohiko ;; Dan Rich ;; Maintainer: MORIOKA Tomohiko ;; Created: 1995/12/15 -;; Version: $Id: tm-image.el,v 1.3 1997/02/08 03:26:13 steve Exp $ +;; Version: $Id: tm-image.el,v 1.4 1997/02/15 22:21:29 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, image, picture, X-Face +;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news -;; This file is part of tm (Tools for MIME). +;; This file is part of XEmacs. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -24,8 +24,8 @@ ;; 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 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: @@ -37,113 +37,105 @@ (require 'tm-view) (cond (running-xemacs - (require 'annotations) - - (set-alist 'mime-viewer/content-filter-alist - "image/jpeg" - (if (featurep 'jpeg) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) - - (set-alist 'mime-viewer/content-filter-alist - "image/gif" - (if (featurep 'gif) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) + (require 'images) - (set-alist 'mime-viewer/content-filter-alist - "image/x-xpixmap" - (if (featurep 'xpm) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) - - (set-alist 'mime-viewer/content-filter-alist - "image/tiff" (function mime-preview/filter-for-image)) - (set-alist 'mime-viewer/content-filter-alist - "image/x-tiff" (function mime-preview/filter-for-image)) + (defun-maybe image-inline-p (format) + (or (memq format image-native-formats) + (find-if (function + (lambda (native) + (image-converter-chain format native) + )) + image-native-formats) + )) - (set-alist 'mime-viewer/content-filter-alist - "image/x-pic" (function mime-preview/filter-for-image)) - - (set-alist 'mime-viewer/content-filter-alist - "image/x-mag" (function mime-preview/filter-for-image)) - - (defvar tm-image/inline-image-types - (if (featurep 'gif) - (nconc - '("image/jpeg" "image/gif" "image/tiff" - "image/x-tiff" "image/x-pic" "image/x-mag" - "image/x-xbm" "image/x-xpixmap") - (if (featurep 'gif) - '("application/postscript") - ) - ))) + (image-register-netpbm-utilities) + (image-register-converter 'pic 'ppm "pictoppm") + (image-register-converter 'mag 'ppm "magtoppm") (defun bitmap-insert-xbm-file (file) - (let (gl) - (while (progn - (setq gl (make-glyph file)) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (make-annotation gl (point) 'text) + (let ((gl (make-glyph (list (cons 'x file)))) + (e (make-extent (point) (point))) + ) + (set-extent-end-glyph e gl) )) - (defvar mime-viewer/image-converter-alist - '(("image/jpeg" . jpeg) - ("image/gif" . gif) - ("image/x-png" . png) - ("image/x-xpixmap" . xpm) - )) - - (defvar mime-preview/x-face-function - (function mime-preview/x-face-function-use-highlight-headers)) - + ;; + ;; X-Face + ;; (autoload 'highlight-headers "highlight-headers") (defun mime-preview/x-face-function-use-highlight-headers () (highlight-headers (point-min) (re-search-forward "^$" nil t) t) ) + + (add-hook 'mime-viewer/content-header-filter-hook + 'mime-preview/x-face-function-use-highlight-headers) + ) ((featurep 'mule) ;; for MULE 2.* or mule merged EMACS (require 'x-face-mule) + + (defvar image-native-formats '(xbm)) - (defvar tm-image/inline-image-types '("image/x-mag" "image/x-xbm")) + (defun-maybe image-inline-p (format) + (memq format image-native-formats) + ) - (defvar mime-preview/x-face-function - (function x-face-decode-message-header)) + (defun-maybe image-normalize (format data) + (and (eq format 'xbm) + (vector 'xbm ':data data) + )) + + ;; + ;; X-Face + ;; + (if (file-installed-p uncompface-program exec-path) + (add-hook 'mime-viewer/content-header-filter-hook + 'x-face-decode-message-header) + ) )) -(defvar mime-viewer/shell-command "/bin/sh") -(defvar mime-viewer/shell-arguments '("-c")) +(or (fboundp 'image-invalid-glyph-p) + (defsubst image-invalid-glyph-p (glyph) + (or (null (aref glyph 0)) + (null (aref glyph 2)) + (equal (aref glyph 2) "") + )) + ) + +(defvar mime-viewer/image-converter-alist nil) + +(mapcar (function + (lambda (rule) + (let ((ctype (car rule)) + (format (cdr rule)) + ) + (if (image-inline-p format) + (progn + (set-alist 'mime-viewer/content-filter-alist + ctype + (function mime-preview/filter-for-image)) + (set-alist 'mime-viewer/image-converter-alist + ctype format) + (add-to-list + 'mime-viewer/default-showing-Content-Type-list + ctype) + ) + )))) + '(("image/jpeg" . jpeg) + ("image/gif" . gif) + ("image/tiff" . tiff) + ("image/x-tiff" . tiff) + ("image/xbm" . xbm) + ("image/x-xbm" . xbm) + ("image/x-xpixmap" . xpm) + ("image/x-pic" . pic) + ("image/x-mag" . mag) + )) (defvar mime-viewer/ps-to-gif-command "pstogif") -(defvar mime-viewer/graphic-converter-alist - '(("image/jpeg" . "djpeg -color 256 < %s | ppmtoxpm > %s") - ("image/gif" . "giftopnm < %s | ppmtoxpm > %s") - ("image/tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-pic" . "pictoppm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-mag" . "magtoppm < %s | ppmtoxpm > %s") - )) - - -;;; @ X-Face -;;; - -(defvar mime-viewer/x-face-to-xbm-command - (concat mime-viewer/x-face-to-pbm-command " | pbmtoxbm")) - -(if mime-preview/x-face-function - (add-hook 'mime-viewer/content-header-filter-hook - mime-preview/x-face-function) - ) - ;;; @ content filter for images ;;; @@ -152,87 +144,38 @@ (defun mime-preview/filter-for-image (ctype params encoding) (let* ((mode mime::preview/original-major-mode) (m (assq mode mime-viewer/code-converter-alist)) - (filter (assoc-value ctype mime-viewer/graphic-converter-alist)) - ) - (if filter - (let* ((beg (point-min)) (end (point-max)) - (orig-file - (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - (xbm-file (concat orig-file ".xbm")) - gl annot) - ;;(remove-text-properties beg end '(face nil)) - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) orig-file) - (delete-region (point-min)(point-max)) - (message "Now translating, please wait...") - (apply (function call-process) - mime-viewer/shell-command nil nil nil - (append mime-viewer/shell-arguments - (list (format filter orig-file xbm-file))) - ) - (setq gl (make-glyph xbm-file)) - (setq annot (make-annotation gl (point) 'text)) - (unwind-protect - (delete-file orig-file) - (condition-case nil - (delete-file xbm-file) - (error nil))) - (goto-char (point-max)) - (insert "\n") - (message "Translation done.") - ) - (message (format "%s is not supported." ctype)) - ))) - - -;;; @ content filter for xbm -;;; - -(defun mime-preview/filter-for-image/xbm (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (assoc "charset" params)) - (beg (point-min)) (end (point-max)) - (xbm-file (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - ) - (remove-text-properties beg end '(face nil)) - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) xbm-file) - (delete-region (point-min)(point-max)) - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - )) - -(set-alist 'mime-viewer/content-filter-alist - "image/xbm" (function mime-preview/filter-for-image/xbm)) - -(set-alist 'mime-viewer/content-filter-alist - "image/x-xbm" (function mime-preview/filter-for-image/xbm)) - - -;;; @ content filter for support in-line image types -;;; -;; (for XEmacs 19.14 or later) - -(defun mime-preview/filter-for-inline-image (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) (charset (assoc "charset" params)) (beg (point-min)) (end (point-max)) ) (remove-text-properties beg end '(face nil)) + (message "Decoding image...") (mime-decode-region beg end encoding) - (let ((data (buffer-string)) - (minor (assoc-value ctype mime-viewer/image-converter-alist)) - gl e) + (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist)) + (gl (image-normalize minor (buffer-string))) + e) (delete-region (point-min)(point-max)) - (while (progn - (setq gl (make-glyph (vector minor :data data))) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (setq e (make-extent (point) (point))) - (set-extent-end-glyph e gl) + (cond ((image-invalid-glyph-p gl) + (setq gl nil) + (message "Invalid glyph!") + ) + ((eq (aref gl 0) 'xbm) + (let ((xbm-file + (make-temp-name (expand-file-name "tm" mime/tmp-dir)))) + (insert (aref gl 2)) + (write-region (point-min)(point-max) xbm-file) + (message "Decoding image...") + (delete-region (point-min)(point-max)) + (bitmap-insert-xbm-file xbm-file) + (delete-file xbm-file) + ) + (message "Decoding image... done") + ) + (t + (setq gl (make-glyph gl)) + (setq e (make-extent (point) (point))) + (set-extent-end-glyph e gl) + (message "Decoding image... done") + )) ) (insert "\n") )) @@ -251,18 +194,15 @@ (gif-file (concat file-base ".gif")) ) (remove-text-properties beg end '(face nil)) + (message "Decoding Postscript...") (mime-decode-region beg end encoding) (write-region (point-min)(point-max) ps-file) + (message "Decoding Postscript...") (delete-region (point-min)(point-max)) (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file) - (let (gl) - (while (progn - (setq gl (make-glyph (vector 'gif :file gif-file))) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (make-annotation gl (point) 'text) - ) + (set-extent-end-glyph (make-extent (point) (point)) + (make-glyph (vector 'gif :file gif-file))) + (message "Decoding Postscript... done") (delete-file ps-file) (delete-file gif-file) )) @@ -271,18 +211,10 @@ "application/postscript" (function mime-preview/filter-for-application/postscript)) - -;;; @ setting -;;; - -(mapcar - (lambda (ctype) - (or (member ctype mime-viewer/default-showing-Content-Type-list) - (setq mime-viewer/default-showing-Content-Type-list - (cons ctype - mime-viewer/default-showing-Content-Type-list)) - )) - tm-image/inline-image-types) +(if (featurep 'gif) + (add-to-list 'mime-viewer/default-showing-Content-Type-list + "application/postscript") + ) ;;; @ end diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-partial.el --- a/lisp/tm/tm-partial.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-partial.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,11 +1,11 @@ ;;; tm-partial.el --- Grabbing all MIME "message/partial"s. -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: OKABE Yasuo @ Kyoto University ;; MORIOKA Tomohiko ;; Version: -;; $Id: tm-partial.el,v 1.2 1996/12/28 21:03:15 steve Exp $ +;; $Id: tm-partial.el,v 1.3 1997/02/15 22:21:29 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, message/partial ;; This file is a part of tm (Tools for MIME). @@ -21,8 +21,8 @@ ;; 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: @@ -34,16 +34,16 @@ ;; display Article at the cursor in Subject buffer. (defun tm-partial/preview-article (target) - (let ((f (assq target tm-partial/preview-article-method-alist))) - (if f - (funcall (cdr f)) - (error "Fatal. Unsupported mode") - ))) + (save-window-excursion + (let ((f (assq target tm-partial/preview-article-method-alist))) + (if f + (funcall (cdr f)) + (error "Fatal. Unsupported mode") + )))) (defun mime-article/grab-message/partials (beg end cal) (interactive) (let* ((id (cdr (assoc "id" cal))) - (buffer (generate-new-buffer id)) (mother mime::article/preview-buffer) (target (cdr (assq 'major-mode cal))) (article-buffer (buffer-name (current-buffer))) @@ -63,43 +63,41 @@ (if (or (file-exists-p full-file) (not (y-or-n-p "Merge partials?")) ) - (progn - (kill-buffer buffer) - (mime-article/decode-message/partial beg end cal) - ) + (mime-article/decode-message/partial beg end cal) (let (cinfo the-id parameters) (setq subject-id (std11-field-body "Subject")) (if (string-match "[0-9\n]+" subject-id) (setq subject-id (substring subject-id 0 (match-beginning 0))) ) - (pop-to-buffer subject-buf) - (while (search-backward subject-id nil t) - ) - (catch 'tag - (while t - (tm-partial/preview-article target) - (pop-to-buffer article-buffer) - (switch-to-buffer mime::article/preview-buffer) - (setq cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - (setq parameters (mime::content-info/parameters cinfo)) - (setq the-id (assoc-value "id" parameters)) - (if (equal the-id id) - (progn - (switch-to-buffer article-buffer) - (mime-article/decode-message/partial - (point-min)(point-max) parameters) - (if (file-exists-p full-file) - (throw 'tag nil) - ) - )) - (if (not (progn - (pop-to-buffer subject-buf) - (end-of-line) - (search-forward subject-id nil t) - )) - (error "not found") + (save-excursion + (set-buffer subject-buf) + (while (search-backward subject-id nil t)) + (catch 'tag + (while t + (tm-partial/preview-article target) + (set-buffer article-buffer) + (set-buffer mime::article/preview-buffer) + (setq cinfo + (mime::preview-content-info/content-info + (car mime::preview/content-list))) + (setq parameters (mime::content-info/parameters cinfo)) + (setq the-id (assoc-value "id" parameters)) + (if (equal the-id id) + (progn + (set-buffer article-buffer) + (mime-article/decode-message/partial + (point-min)(point-max) parameters) + (if (file-exists-p full-file) + (throw 'tag nil) + ) + )) + (if (not (progn + (set-buffer subject-buf) + (end-of-line) + (search-forward subject-id nil t) + )) + (error "not found") + ) ) )))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-pgp.el --- a/lisp/tm/tm-pgp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-pgp.el Mon Aug 13 09:13:56 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.2 1996/12/28 21:03:15 steve Exp $ +;; Version: $Id: tm-pgp.el,v 1.3 1997/02/15 22:21:29 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, PGP, security ;; This file is part of tm (Tools for MIME). @@ -29,20 +28,18 @@ ;; 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) @@ -53,19 +50,22 @@ (defun mime-article/view-application/pgp (beg end cal) (let* ((cnum (mime-article/point-content-number beg)) (cur-buf (current-buffer)) + (p-win (or (get-buffer-window mime::article/preview-buffer) + (get-largest-window))) (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)) - (switch-to-buffer new-name) + code-converter + (str (buffer-substring beg end)) + ) + (set-buffer (get-buffer-create new-name)) (erase-buffer) (insert str) (cond ((progn (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) ) - (mc-verify) + (funcall (pgp-function 'verify)) (goto-char (point-min)) (delete-region (point-min) @@ -91,7 +91,7 @@ (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) ) - (as-binary-process (mc-decrypt)) + (as-binary-process (funcall (pgp-function 'decrypt))) (goto-char (point-min)) (delete-region (point-min) (and @@ -101,7 +101,8 @@ )) (setq major-mode 'mime/show-message-mode) (setq mime::article/code-converter code-converter) - (mime/viewer-mode mother) + (save-window-excursion (mime/viewer-mode mother)) + (set-window-buffer p-win mime::article/preview-buffer) )) (set-atype 'mime/content-decoding-condition @@ -117,7 +118,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 +187,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 +203,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 +227,7 @@ (format "Key %s not found; attempt to fetch? " pgp-id)) ) (progn - (mc-pgp-fetch-key (cons nil pgp-id)) + (funcall (pgp-function 'fetch-key) (cons nil pgp-id)) (mime::article/call-pgp-to-check-signature mime/output-buffer-name orig-file) )) @@ -264,7 +248,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 +274,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 +295,7 @@ (delete-region (point-min) (match-end 0)) ) (mime-decode-region (point-min)(point-max) encoding) - (mc-snarf-keys) + (funcall (pgp-function 'snarf-keys)) (kill-buffer (current-buffer)) )) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-play.el --- a/lisp/tm/tm-play.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-play.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,10 +1,10 @@ ;;; tm-play.el --- decoder for tm-view.el -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1995/9/26 (separated from tm-view.el) -;; Version: $Id: tm-play.el,v 1.1.1.2 1996/12/21 20:50:43 steve Exp $ +;; Version: $Id: tm-play.el,v 1.2 1997/02/15 22:21:29 steve Exp $ ;; Keywords: mail, news, MIME, multimedia ;; This file is part of tm (Tools for MIME). @@ -269,16 +269,44 @@ ;;; (defvar mime-article/coding-system-alist - (and (boundp 'MULE) - '((mh-show-mode . *noconv*) - (t . *ctext*) - ))) + (list (cons 'mh-show-mode *noconv*) + (cons t (mime-charset-to-coding-system default-mime-charset)) + )) -(defvar mime-article/kanji-code-alist - (and (boundp 'NEMACS) - '((mh-show-mode . nil) - (t . 2) - ))) +(cond (running-mule-merged-emacs + (defun mime-article::write-region (start end file) + (let ((coding-system-for-write + (cdr + (or (assq major-mode mime-article/coding-system-alist) + (assq t mime-article/coding-system-alist) + )))) + (write-region start end file) + )) + ) + ((or (boundp 'MULE) + running-xemacs-with-mule) + (defun mime-article::write-region (start end file) + (let ((file-coding-system + (cdr + (or (assq major-mode mime-article/coding-system-alist) + (assq t mime-article/coding-system-alist) + )))) + (write-region start end file) + )) + ) + ((boundp 'NEMACS) + (defun mime-article::write-region (start end file) + (let ((kanji-fileio-code + (cdr + (or (assq major-mode mime-article/kanji-code-alist) + (assq t mime-article/kanji-code-alist) + )))) + (write-region start end file) + )) + ) + (t + (defalias 'mime-article::write-region 'write-region) + )) (defun mime-article/decode-message/partial (beg end cal) (goto-char beg) @@ -287,101 +315,134 @@ (id (cdr (assoc "id" cal))) (number (cdr (assoc "number" cal))) (total (cdr (assoc "total" cal))) - (the-buf (current-buffer)) file (mother mime::article/preview-buffer) - (win-conf (save-excursion - (set-buffer mother) - mime::preview/original-window-configuration)) - ) - (if (not (file-exists-p root-dir)) + ) + (or (file-exists-p root-dir) (make-directory root-dir) - ) + ) (setq id (replace-as-filename id)) (setq root-dir (concat root-dir "/" id)) - (if (not (file-exists-p root-dir)) + (or (file-exists-p root-dir) (make-directory root-dir) - ) + ) (setq file (concat root-dir "/FULL")) - (if (not (file-exists-p file)) - (progn - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) - (setq file (concat root-dir "/" number)) - (let ((file-coding-system - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - ))) - (kanji-fileio-code - (cdr - (or (assq major-mode mime-article/kanji-code-alist) - (assq t mime-article/kanji-code-alist) - ))) - ) - (write-region (point) (point-max) file) - ) - (if (get-buffer mime/temp-buffer-name) - (kill-buffer mime/temp-buffer-name) + (if (file-exists-p file) + (let ((full-buf (get-buffer-create "FULL")) + (pwin (or (get-buffer-window mother) + (get-largest-window))) + ) + (save-window-excursion + (set-buffer full-buf) + (erase-buffer) + (as-binary-input-file (insert-file-contents file)) + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) ) - (switch-to-buffer mime/temp-buffer-name) - (let ((i 1) - (max (string-to-int total)) - (file-coding-system-for-read (if (boundp 'MULE) - *noconv*)) - kanji-fileio-code) - (catch 'tag - (while (<= i max) - (setq file (concat root-dir "/" (int-to-string i))) - (if (not (file-exists-p file)) - (progn - (switch-to-buffer the-buf) - (throw 'tag nil) - )) - (insert-file-contents file) - (goto-char (point-max)) - (setq i (1+ i)) - ) - ;;(delete-other-windows) - (let ((buf (current-buffer))) - (write-file (concat root-dir "/FULL")) - (set-window-configuration win-conf) - (let ((win (get-buffer-window mother))) - (if win - (select-window win) + (set-window-buffer pwin + (save-excursion + (set-buffer full-buf) + mime::article/preview-buffer)) + (select-window pwin) + ) + (re-search-forward "^$") + (goto-char (1+ (match-end 0))) + (setq file (concat root-dir "/" number)) + (mime-article::write-region (point) (point-max) file) + (let ((total-file (concat root-dir "/CT"))) + (setq total + (if total + (progn + (or (file-exists-p total-file) + (save-excursion + (set-buffer + (get-buffer-create mime/temp-buffer-name)) + (erase-buffer) + (insert total) + (write-file total-file) + (kill-buffer (current-buffer)) + )) + (string-to-number total) + ) + (and (file-exists-p total-file) + (save-excursion + (set-buffer (find-file-noselect total-file)) + (prog1 + (and (re-search-forward "[0-9]+" nil t) + (string-to-number + (buffer-substring (match-beginning 0) + (match-end 0))) + ) + (kill-buffer (current-buffer)) + ))) + ))) + (if (and total (> total 0)) + (catch 'tag + (save-excursion + (set-buffer (get-buffer-create mime/temp-buffer-name)) + (let ((full-buf (current-buffer))) + (erase-buffer) + (let ((i 1)) + (while (<= i total) + (setq file (concat root-dir "/" (int-to-string i))) + (or (file-exists-p file) + (throw 'tag nil) + ) + (as-binary-input-file (insert-file-contents file)) + (goto-char (point-max)) + (setq i (1+ i)) )) - (set-window-buffer (selected-window) buf) - ;;(set-window-buffer buf) - (setq major-mode 'mime/show-message-mode) - ) - (mime/viewer-mode mother) - (pop-to-buffer (current-buffer)) - )) - ) - (progn - ;;(delete-other-windows) - (set-window-configuration win-conf) - (select-window (or (get-buffer-window mother) - (get-buffer-window - (save-excursion - (set-buffer mother) - mime::preview/article-buffer)) - (get-largest-window) + (as-binary-output-file (write-file (concat root-dir "/FULL"))) + (let ((i 1)) + (while (<= i total) + (let ((file (format "%s/%d" root-dir i))) + (and (file-exists-p file) + (delete-file file) )) - (as-binary-input-file - (set-buffer (get-buffer-create "FULL")) - (insert-file-contents file) - ) - (setq major-mode 'mime/show-message-mode) - (mime/viewer-mode mother) - ;;(pop-to-buffer (current-buffer)) - )) - )) + (setq i (1+ i)) + )) + (let ((file (expand-file-name "CT" root-dir))) + (and (file-exists-p file) + (delete-file file) + )) + (save-window-excursion + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) + ) + (let ((pwin (or (get-buffer-window mother) + (get-largest-window) + )) + (pbuf (save-excursion + (set-buffer full-buf) + mime::article/preview-buffer))) + (set-window-buffer pwin pbuf) + (select-window pwin) + ))))) + ))) ;;; @ rot13-47 ;;; +(require 'view) + +(defconst mime-view-text/plain-mode-map (copy-keymap view-mode-map)) +(define-key mime-view-text/plain-mode-map + "q" (function mime-view-text/plain-exit)) + +(defun mime-view-text/plain-mode () + "\\{mime-view-text/plain-mode-map}" + (setq buffer-read-only t) + (setq major-mode 'mime-view-text/plain-mode) + (setq mode-name "MIME-View text/plain") + (use-local-map mime-view-text/plain-mode-map) + ) + +(defun mime-view-text/plain-exit () + (interactive) + (kill-buffer (current-buffer)) + ) + (defun mime-article/decode-caesar (beg end cal) (let* ((cnum (mime-article/point-content-number beg)) (cur-buf (current-buffer)) @@ -392,7 +453,14 @@ (mode major-mode) str) (setq str (buffer-substring beg end)) - (switch-to-buffer new-name) + (let ((pwin (or (get-buffer-window mother) + (get-largest-window))) + (buf (get-buffer-create new-name)) + ) + (set-window-buffer pwin buf) + (set-buffer buf) + (select-window pwin) + ) (setq buffer-read-only nil) (erase-buffer) (insert str) @@ -410,7 +478,8 @@ (goto-char (point-max)) (tm:caesar-region) ) - (view-mode) + (set-buffer-modified-p nil) + (mime-view-text/plain-mode) )) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-rmail.el --- a/lisp/tm/tm-rmail.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-rmail.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,11 +1,11 @@ ;;; tm-rmail.el --- MIME extension for RMAIL -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; modified by KOBAYASHI Shuhei ;; Created: 1994/8/30 -;; Version: $Revision: 1.1.1.2 $ +;; Version: $Revision: 1.2 $ ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word ;; This file is not part of tm (Tools for MIME). @@ -40,7 +40,7 @@ ;;; (defconst tm-rmail/RCS-ID - "$Id: tm-rmail.el,v 1.1.1.2 1996/12/21 20:50:48 steve Exp $") + "$Id: tm-rmail.el,v 1.2 1997/02/15 22:21:30 steve Exp $") (defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID)) (defvar tm-rmail/decode-all nil) @@ -189,8 +189,16 @@ (defun tm-rmail/quitting-method-to-article () (setq tm-rmail/decode-all nil) - (mime-viewer/kill-buffer) - ) + (let ((buffer + (mime::preview-content-info/buffer + (mime-preview/point-pcinfo (point)))) + ) + (mime-viewer/kill-buffer) + + ;; Make sure we return to RMAIL buffer + (if buffer + (switch-to-buffer buffer)) + )) (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-setup.el --- a/lisp/tm/tm-setup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-setup.el Mon Aug 13 09:13:56 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.1.1.2 1996/12/21 20:50:45 steve Exp $ +;; Version: $Id: tm-setup.el,v 1.2 1997/02/15 22:21:30 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -19,8 +19,8 @@ ;; 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: @@ -42,10 +42,10 @@ (set-atype 'mime/content-decoding-condition '((type . "message/external-body") ("access-type" . "anon-ftp") - (method . mime/decode-message/external-ftp) + (method . mime-article/decode-message/external-ftp) )) - (autoload 'mime/decode-message/external-ftp "tm-ftp") - + (autoload 'mime-article/decode-message/external-ftp "tm-ftp") + ;; for LaTeX (set-atype 'mime/content-decoding-condition '((type . "text/x-latex") @@ -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 () @@ -85,14 +98,15 @@ ;;; @ for RMAIL ;;; -(or running-xemacs-with-mule - (call-after-loaded 'rmail - (function - (lambda () - (require 'tm-rmail) - )) - 'rmail-mode-hook) - ) +(defun tm-setup/load-rmail () + (or (and (boundp 'rmail-support-mime) + rmail-support-mime) + (require 'tm-rmail) + ) + (remove-hook 'rmail-mode-hook 'tm-setup/load-rmail) + ) + +(call-after-loaded 'rmail 'tm-setup/load-rmail 'rmail-mode-hook) ;;; @ for mh-e diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-view.el --- a/lisp/tm/tm-view.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-view.el Mon Aug 13 09:13:56 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.1.1.2 $ +;; Version: $Revision: 1.2 $ ;; 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.1.1.2 1996/12/21 20:50:43 steve Exp $") + "$Id: tm-view.el,v 1.2 1997/02/15 22:21:30 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' @@ -1004,8 +1007,14 @@ )) (mime/decode-message-header) ) - (funcall (cdr (assq mode mime-viewer/following-method-alist)) - new-buf) + (let ((f (cdr (assq mode mime-viewer/following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + (format + "Sorry, following method for %s is not implemented yet." + mode)) + )) )))) (defun mime-viewer/display-x-face () diff -r 498bf5da1c90 -r 0d2f883870bc lisp/tm/tm-vm.el --- a/lisp/tm/tm-vm.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tm-vm.el Mon Aug 13 09:13:56 2007 +0200 @@ -9,7 +9,7 @@ ;; Oscar Figueiredo ;; Maintainer: Oscar Figueiredo ;; Created: 1994/10/29 -;; Version: $Revision: 1.1.1.2 $ +;; Version: $Revision: 1.2 $ ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -36,30 +36,260 @@ ;;; Code: (eval-when-compile - (require 'tm-edit) (require 'tm-mail) (require 'vm) (require 'vm-window)) +(require 'tm-edit) (require 'tm-view) +(require 'vm-reply) +(require 'vm-summary) +(require 'vm-menu) +(require 'vm-toolbar) + + +;;; @ 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 (or (and (boundp 'vm-display-using-mime) + vm-display-using-mime) + 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'.") + +(defvar tm-vm/build-mime-preview-buffer-hook nil + "*List of functions called each time a MIME Preview buffer is built. +These hooks are run in the MIME-Preview buffer.") + +;;; @@ System/Information variables (defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 1.1.1.2 1996/12/21 20:50:47 steve Exp $") + "$Id: tm-vm.el,v 1.2 1997/02/15 22:21:30 steve Exp $") (defconst tm-vm/version (get-version-string tm-vm/RCS-ID)) +; Ensure vm-menu-mail-menu gets properly defined *before* tm-vm/vm-emulation-map +; since it contains a call to vm-menu-initialize-vm-mode-menu-map +(setq vm-menu-mail-menu + (let ((title (if (vm-menu-fsfemacs-menus-p) + (list "Mail Commands" + "Mail Commands" + "---" + "---") + (list "Mail Commands")))) + (append + title + (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)] + ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)] + ["Cancel" kill-buffer t] + "----" + "Go to Field:" + "----" + [" To:" mail-to t] + [" Subject:" mail-subject t] + [" CC:" mail-cc t] + [" BCC:" mail-bcc t] + [" Reply-To:" mail-replyto t] + [" Text" mail-text t] + "----" + ["Yank Original" vm-menu-yank-original vm-reply-list] + ["Fill Yanked Message" mail-fill-yanked-message t] + ["Insert Signature" mail-signature t] + ["Insert File..." insert-file t] + ["Insert Buffer..." insert-buffer t]) + (if tm-vm/attach-to-popup-menus + (list "----" + (cons "MIME Commands" + (mapcar (function (lambda (item) + (vector (nth 1 item) + (nth 2 item) + t))) + mime-editor/menu-list)))) + ))) + +(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.") +; Disable VM 6 built-in MIME handling +(setq vm-display-using-mime nil) +(setq vm-send-using-mime nil) -(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. @@ -81,28 +311,18 @@ (cdr ret)) ret))) -(require 'vm-summary) -(or (fboundp 'tm:vm-su-subject) - (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject)) - ) -(defun vm-su-subject (m) - (mime-eword/decode-string (tm:vm-su-subject m)) - ) +(defadvice vm-su-subject (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) -(or (fboundp 'tm:vm-su-full-name) - (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name)) - ) -(defun vm-su-full-name (m) - (mime-eword/decode-string (tm:vm-su-full-name m)) - ) +(defadvice vm-su-full-name (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) -(or (fboundp 'tm:vm-su-to-names) - (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names)) - ) -(defun vm-su-to-names (m) - (mime-eword/decode-string (tm:vm-su-to-names m)) - ) -;;; +(defadvice vm-su-to-names (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) + )) (defun tm-vm/decode-message-header (&optional count) @@ -156,30 +376,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 +389,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 +409,138 @@ (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))) + (run-hooks 'tm-vm/build-mime-preview-buffer-hook) + )))) + (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. )) @@ -256,478 +555,94 @@ ) (t ;; don't display if neither mwin nor pwin was displayed before. - ))) - (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 +744,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 +752,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) + (if vm-auto-next-message + (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 ((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 (current-buffer) t '(vm-beginning-of-message) + '(vm-beginning-of-message reading-message)) + (tm-vm/display-preview-buffer) + (tm-vm/save-window-excursion + (select-window (vm-get-visible-buffer-window pbuf)) + (push-mark) + (goto-char (point-min)) + (vm-display (current-buffer) t '(vm-beginning-of-message) + '(vm-beginning-of-message reading-message)) + )))) + +(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 ((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 (current-buffer) t '(vm-end-of-message) + '(vm-end-of-message reading-message)) + (tm-vm/display-preview-buffer) + (tm-vm/save-window-excursion + (select-window (vm-get-buffer-window pbuf)) + (push-mark) + (goto-char (point-max)) + (vm-display (current-buffer) t '(vm-end-of-message) + '(vm-end-of-message reading-message)) + )))) + +;;; 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 + + +(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 +1153,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 +1203,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 +1258,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,29 +1275,11 @@ (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) -;;; modified by Steven L. Baur -;;; 1995/12/6 (c.f. [tm-en:209]) -(defun mime-editor/attach-to-vm-mode-menu () - "Arrange to attach MIME editor's popup menu to VM's" - (if (boundp 'vm-menu-mail-menu) - (progn - (setq vm-menu-mail-menu - (append vm-menu-mail-menu - (list "----" - mime-editor/popup-menu-for-xemacs))) - (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu) - ))) +;;; @@@ Menus + (call-after-loaded 'tm-edit @@ -1065,22 +1294,155 @@ (interactive) (funcall send-mail-function) ))) - (if (and (string-match "XEmacs\\|Lucid" emacs-version) - tm-vm/use-xemacs-popup-menu) - (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)))) +) + +(defadvice vm-save-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-expunge-folder (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-save-folder (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-goto-parent-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-delete-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (interactive "p") + (if (interactive-p) + (vm-follow-summary-cursor)) + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-delete-message-backward (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (interactive "p") + (if (interactive-p) + (vm-follow-summary-cursor)) + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-undelete-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (interactive "p") + (if (interactive-p) + (vm-follow-summary-cursor)) + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-unread-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) + +(defadvice vm-edit-message (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (save-excursion + (set-buffer mime::preview/article-buffer) + ad-do-it) + ad-do-it)) -;;; @ for BBDB + +;;; @@ VM Toolbar Integration + +;;; 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 +1452,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) @@ -1124,6 +1484,8 @@ 'f22 [f22]) 'tm-vm/print-message) + (make-local-variable 'ps-header-lines) + (make-local-variable 'ps-left-header) (setq ps-header-lines 3) (setq ps-left-header (list 'ps-article-subject 'ps-article-author 'buffer-name))) @@ -1133,11 +1495,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 +1507,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 498bf5da1c90 -r 0d2f883870bc lisp/tm/tmh-comp.el --- a/lisp/tm/tmh-comp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/tm/tmh-comp.el Mon Aug 13 09:13:56 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.2 1996/12/28 21:03:16 steve Exp $ +;; Version: $Id: tmh-comp.el,v 1.3 1997/02/15 22:21:31 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 498bf5da1c90 -r 0d2f883870bc lisp/utils/browse-cltl2.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/browse-cltl2.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,383 @@ +; -*- Mode: Emacs-Lisp -*- +;;; browse-cltl2.el --- browse the hypertext-version of +;;; "Common Lisp the Language, 2nd. Edition" + +;; Revision 1.1.1 +;; last edited on 29.1.1997 + +;; Copyright (C) 1997 Holger Schauer + +;; Author: Holger Schauer +;; Keywords: utils lisp ilisp + +;; This file is not part of Emacs. + +;; Developed under XEmacs 19.14. Also tested on Emacs 19.32 and +;; XEmacs 19.11. Should work with newer versions, too. +;; Required: browse-url.el +;; Recommended: url.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: +;; This gives you two top-level-functions useful when programming lisp: +;; cltl2-view-function-definition and cltl2-view-index +;; cltl2-view-function-definition asks you for a name of a lisp +;; function (or variable) and will open up your favourite browser +;; (as specified by `browse-url-browser-function') loading the page +;; which documents it. + +;;; Installation: (as usual) +;; Put browse-cltl2.el somewhere where emacs can find it. +;; browse-cltl2.el requires a working browse-url, url and cl. +;; Insert the following lines in your .emacs: +;; +;; (autoload 'cltl2-view-function-definition "browse-cltl2") +;; (autoload 'cltl2-view-index "browse-cltl2") +;; (autoload 'cltl2-lisp-mode-install "browse-cltl2") +;; (add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) +;; (add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) +;; +;; This should also add the needed hooks to lisp-mode (and ilisp-mode). + +;; Gnu Emacs: +;; For Gnu Emacs there doesn't seem to be a lisp-mode-hook so you're +;; on your own with the key-settings. +;; No url.el: +;; If you don't have url.el set *cltl2-use-url* to nil +;; and set *cltl2-fetch-method* to 'local or 'local-index-only. +;; This implies that you need a local copy of the index page of +;; CLtL2 (which you can get from the normal hypertext-version at CMU), +;; so you need to point *cltl2-local-file-pos* and *cltl2-index-file-name* +;; to the place where you put it. +;; Old versions of Emacs (XEmacs 19.11 for example): +;; When you want to use a local copy (or a local copy of the index file) +;; check the documentation on find-file-noselect. If it doesn't mention +;; an option called RAWFILE set *cltl2-old-find-file-noselect* to 't. + + +;;; Customization: +;; By default, browse-cltl2 will use a local copy of CLtL2, looking +;; for it in /usr/doc/html/cltl. This can be modified with the help +;; of the following variables: +;; *cltl2-fetch-method*, *cltl2-url*, *cltl-local-file-pos* +;; See the documentation on this variables for more info. +;; +;;; TODO: +;; In this version we can't separate between functions, variables, +;; constants and loop clauses. This is not that hard to change, +;; but it is more difficult to distinguish what the user is +;; looking for. Until I receive several requests for it, I won't +;; implement it, because there are not that much constructs like * and + +;; which have two (or more) semantics. + +;;; Changes: +;; 28-01-97: HS: now we're using cl-puthash all over the place because +;; this is common on XEmacs 19.11 and upwards and Gnu Emacs. +;; Added information on how to install without url.el +;; +;; 29-01-97 HS: included conditionalized versions of the required +;; functions match-string and buffer-live-p. +;; Suggested by Simon Marshall . +;; Included new variable *cltl2-use-url* with which one can +;; specify if he has url.el or not. Introduced variable +;; *cltl2-old-find-file-noselect*. +(defvar *cltl2-use-url* 'nil + "Enables or disables retrieval of the index-file via WWW (or more + exactly by the use of the function url-retrieve from url.el). + Default is 't.") + +;; needed things +(require 'cl) +(require 'browse-url) + +(when (not *cltl2-use-url*) + (require 'url)) + +;;; ****************************** +;;; Some variable and constant definitions +;;; ****************************** +(defvar *cltl2-fetch-method* 'local + "This sets the method by which the index-file will be fetched. Three + methods are possible: 'local assumes that all files are local. + 'local-index-only assumes that just the index-file is locally but + all other files will be fetched via www. 'www means that the index-file + will be fetched via WWW, too. Don't change the value of this variable + after loading.") + +(defvar *cltl2-url* + "http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/" + "The url where the hypertext-version of Common Lisp the Language + can be found. Note that this assumes to be the top-level of the + directory structure which should be the same as in the hypertext + version as provided by the CMU AI Repository. Defaults to + http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/ + Note the / at the end.") + +(defvar *cltl2-local-file-pos* "/usr/doc/html/cltl/" + "A directory where the CLtl2 can be found. Note that this assumes + to be the top-level of the directory structure which should be the + same as in the hypertext version as provided by the CMU AI Repository. + Defaults to /usr/doc/html/cltl/ Note the / at the end.") + +(defconst *cltl2-index-file-name* "clm/index.html" + "The name of the index-file, typically with directory on front. + Defaults to clm/index.html, as this is the momentary position from + the top-level directory of the CLtL2-home. Defaults to clm/index.html. + Note that there is no leading /.") + +(defvar *cltl2-index-home* + (concatenate 'string + (case *cltl2-fetch-method* + ('local *cltl2-local-file-pos*) + ('local-index-only *cltl2-local-file-pos*) + ('www *cltl2-url*)) + *cltl2-index-file-name*) + "The absolute path which will be used to fetch the index.") + +(defvar *cltl2-home* + (concatenate + 'string + (case *cltl2-fetch-method* + ('local *cltl2-local-file-pos*) + ('local-index-only *cltl2-url*) + ('www *cltl2-url*)) + "clm/") + "This specifies the home-position of the CLtL2. The value of this variable + will be concatenated with the name of the nodes of the CLtL2.") + +(defvar *cltl2-index-buffer-name* "*cltl2-index*" + "The name of the buffer which holds the index for CLtL2.") + +(defvar *cltl2-old-find-file-noselect* 'nil + "Older versions of Emacs (at least XEmacs 19.11) don't support the + option RAWFILE with the function FIND-FILE-NO-SELECT. Set this variable + to 't if you have such an old version. It will cause fontification and + other useless stuff on the buffer in which the index is fetched. If + you don't use a local copy (of the index) this won't bother you.") + +(defvar *browse-cltl2-ht* (make-hash-table 0)) +(defconst *cltl2-search-regexpr* + "    \\(.+\\)" + "A regular expression how to check for entries in the index-file + of CLtL2. Note that you have to modify this and the + prepare-get-entry*-functions if you want to change the search.") + +;;; ****************************** +;;; First of all: Compatibility stuff +;;; ****************************** +; no match-string in old versions +(if (not (fboundp (function match-string))) + (defun match-string (num &optional string) + "Return string of text matched by last search. + NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. + Zero means the entire text matched by the whole regexp or whole string. + STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring + (match-beginning num) (match-end num)))))) + +; no buffer-live-p in old versions + (if (not (fboundp (function buffer-live-p))) + (defun buffer-live-p (buf-or-name) + "Checks if BUF-OR-NAME is a live buffer. Returns non-nil + if BOF-OR-NAME is an editor buffer which has not been deleted. + Imitating a built-in function from newer Emacs versions." + (let ((object (if (bufferp buf-or-name) + buf-or-name + (get-buffer buf-or-name)))) + (and (bufferp object) (buffer-name object))))) + +; no add-submenu in old versions of XEmacs +(if (and (string-match "XEmacs\\|Lucid" emacs-version) + (not (fboundp 'add-submenu))) + (defun add-submenu (menu-path submenu &optional before) + "Add a menu to the menubar or one of its submenus. +If the named menu exists already, it is changed. +MENU-PATH identifies the menu under which the new menu should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". + If MENU-PATH is nil, then the menu will be added to the menubar itself. +SUBMENU is the new menu to add. + See the documentation of `current-menubar' for the syntax. +BEFORE, if provided, is the name of a menu before which this menu should + be added, if this menu is not on its parent already. If the menu is already + present, it will not be moved." + (add-menu menu-path (car submenu) (cdr submenu) before))) + +; old find-file-noselect has no RAWFILE argument +(if *cltl2-old-find-file-noselect* + (unless (boundp 'cltl2-old-find-file-noselect-func) + (setf (symbol-value 'cltl2-old-find-file-noselect-func) + (symbol-function 'find-file-noselect)) + (setf (symbol-function 'find-file-noselect) + #'(lambda (file &optional nowarn rawfile) + (funcall cltl2-old-find-file-noselect-func file nowarn))))) + +;;; ****************************** +;;; Functions for fetching the index file +;;; ****************************** +(defun cltl2-fetch-index () + "Fetches the index page of the CLtl2 and puts it in its own + buffer called *cltl2-index*." + ;; if the index isn't here load it into a buffer + (when (or (not (get-buffer *cltl2-index-buffer-name*)) + (not (buffer-live-p *cltl2-index-buffer-name*))) + (message "Fetching the CLtL2 index file ...") + (case *cltl2-fetch-method* + ('local + (cltl2-fetch-index-by-file)) + ('local-index-only + (cltl2-fetch-index-by-file)) + ('www + (cltl2-fetch-index-by-www)))) + + (cltl2-prepare-index) +) + +;; fetch methods +(defun cltl2-fetch-index-by-file () + "Fetch the index from disk." + (setf *cltl2-index-buffer-name* + (find-file-noselect *cltl2-index-home* 'nil 't)) +) + +(defun cltl2-fetch-index-by-www () + "Fetch the index via WWW." + (save-excursion + (let ((old-url-working-buffer url-working-buffer)) + (setf url-working-buffer *cltl2-index-buffer-name*) + (url-retrieve *cltl2-index-home*) + (setf url-working-buffer old-url-working-buffer)))) + + +;;; ****************************** +;;; Main functions for viewing +;;; ****************************** +(defun cltl2-view-function-definition (entry) + "First checks if function can be found in the CLtL2-index-file. + If it can be found, uses the function browse-url to have a look + at the corresponding documentation from CLtL2." + (interactive "sCLtL2-Entry to lookup:") + (when (cltl2-index-unprepared-p) + (cltl2-fetch-index)) + + (let ((entry-url (cltl2-find-url-for-function (intern entry)))) + (when entry-url + (message "Loading found entry for %s into browser.." entry) + (browse-url + (concatenate 'string *cltl2-home* entry-url))))) + +(defun cltl2-find-url-for-function (entry) + "Checks if we can find a page for function ENTRY and + constructs an URL from it." + (let ((entry-url (gethash entry *browse-cltl2-ht*))) + (when (not entry-url) + (error "No entry in CLtL2 for %s" entry)) + entry-url)) + +(defun cltl2-view-index () + "Browse-urls the index file." + (interactive) + (browse-url *cltl2-index-home*)) + +;;; ****************************** +;;; Preparing the index (the hashtable) +;;; ****************************** +(defun cltl2-prepare-index () + "Jumps to the *cltl2-index* buffer and scans it, creating a hashtable + for all entries." + (message "Preparing CLtL2 index.") + (save-excursion + (set-buffer *cltl2-index-buffer-name*) + (goto-char (point-min)) + + ; search for entry + (do ((point (re-search-forward + *cltl2-search-regexpr* + nil t) + (re-search-forward + *cltl2-search-regexpr* + nil t))) + ; until we can't find anymore + ((null point)); (format "Index-preparation done.")) + ; put found entry in hash-table + (cl-puthash + (cltl2-prepare-get-entry-name) + (cltl2-prepare-get-entry-url) + *browse-cltl2-ht*)))) + +(defun cltl2-prepare-get-entry-name () + "Get the enrty name from the last match of regexp-search for entries." + (let ((name-string (intern (match-string 2)))) + (format "%s" name-string) + name-string)) + +(defun cltl2-prepare-get-entry-url () + "Get the enrty url from the last match of regexp-search for entries." + (let ((url (match-string 1))) + (format "%s" url) + url)) + +(defun cltl2-index-unprepared-p () + "Check if the index is already prepared." + ; If the hashtable has entries the index is prepared. + (not (and (hash-table-p *browse-cltl2-ht*) + (>= (hash-table-count *browse-cltl2-ht*) 1)))) + +;;; ****************************** +;;; Hooking into lisp mode and ilisp-mode +;;; ****************************** +(defun cltl2-lisp-mode-install () + "Not to be called by the user - just for lisp-mode-hook and ilisp-mode-hook. + + Adds browse-cltl2 to lisp-mode. If you use ilisp (installed via a hook + on lisp-mode) add browse-cltl2 to ilisp. Under Ilisp we use C-zb and C-zB + and without Ilisp we use C-cb and C-cB for calling the cltl2-view-functions. + Under XEmacs we will add ourself to the corresponding menus if there exists + one.." + ; set key bindings + (cond ((featurep 'ilisp) + (local-set-key "\C-zb" 'cltl2-view-function-definition) + (local-set-key "\C-zB" 'cltl2-view-index)) + (t + (local-set-key "\C-cb" 'cltl2-view-function-definition) + (local-set-key "\C-cB" 'cltl2-view-index))) + ; under XEmacs hook ourself into the menu if there is one + (when (string-match "XEmacs\\|Lucid" emacs-version) + ; this is for the menu as provided by ilisp-easy-menu + (cond ((not (null (car (find-menu-item current-menubar '("ILisp"))))) + (add-submenu + '("ILisp" "Documentation") + '("Browse CLtL2" + [ "View entry" cltl2-view-function-definition t] + [ "View index" cltl2-view-index t] ))) + ((not (null (car (find-menu-item current-menubar '("Lisp"))))) + (add-submenu + '("Lisp") + '("Browse CLtL2" + [ "View entry" cltl2-view-function-definition t] + [ "View index" cltl2-view-index t] ))))) +) + +(add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) +(add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) + +;;; Providing ourself. +(provide 'ilisp-browse-cltl2) +;;; browse-cltl2.el ends here. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/utils/edmacro.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/edmacro.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,715 @@ +;;; edmacro.el --- keyboard macro editor + +;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. + +;; Author: Dave Gillespie +;; Maintainer: Dave Gillespie +;; Version: 2.01 +;; Keywords: abbrev + +;; 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: + +;;; Usage: +;; +;; The `C-x C-k' (`edit-kbd-macro') command edits a keyboard macro +;; in a special buffer. It prompts you to type a key sequence, +;; which should be one of: +;; +;; * RET or `C-x e' (call-last-kbd-macro), to edit the most +;; recently defined keyboard macro. +;; +;; * `M-x' followed by a command name, to edit a named command +;; whose definition is a keyboard macro. +;; +;; * `C-h l' (view-lossage), to edit the 100 most recent keystrokes +;; and install them as the "current" macro. +;; +;; * any key sequence whose definition is a keyboard macro. +;; +;; This file includes a version of `insert-kbd-macro' that uses the +;; more readable format defined by these routines. +;; +;; Also, the `read-kbd-macro' command parses the region as +;; a keyboard macro, and installs it as the "current" macro. +;; This and `format-kbd-macro' can also be called directly as +;; Lisp functions. + +;; Type `C-h m', or see the documentation for `edmacro-mode' below, +;; for information about the format of written keyboard macros. + +;; `edit-kbd-macro' formats the macro with one command per line, +;; including the command names as comments on the right. If the +;; formatter gets confused about which keymap was used for the +;; characters, the command-name comments will be wrong but that +;; won't hurt anything. + +;; With a prefix argument, `edit-kbd-macro' will format the +;; macro in a more concise way that omits the comments. + +;; This package requires GNU Emacs 19 or later, and daveg's CL +;; package 2.02 or later. (CL 2.02 comes standard starting with +;; Emacs 19.18.) This package does not work with Emacs 18 or +;; Lucid Emacs. + +;; You bet it does. -hniksic + +;;; Code: + +(eval-when-compile + (require 'cl)) + +;;; The user-level commands for editing macros. + +;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro) + +;;;###autoload +(defvar edmacro-eight-bits nil + "*Non-nil if edit-kbd-macro should leave 8-bit characters intact. +Default nil means to write characters above \\177 in octal notation.") + +(defvar edmacro-mode-map nil) +(unless edmacro-mode-map + (setq edmacro-mode-map (make-sparse-keymap)) + (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit) + (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key)) + +(defvar edmacro-store-hook) +(defvar edmacro-finish-hook) +(defvar edmacro-original-buffer) + +;;;###autoload +(defun edit-kbd-macro (keys &optional prefix finish-hook store-hook) + "Edit a keyboard macro. +At the prompt, type any key sequence which is bound to a keyboard macro. +Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit +the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by +its command name. +With a prefix argument, format the macro in a more concise way." + (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP") + (when keys + (let ((cmd (if (arrayp keys) (key-binding keys) keys)) + (mac nil)) + (cond (store-hook + (setq mac keys) + (setq cmd nil)) + ((or (eq cmd 'call-last-kbd-macro) + (member keys '("\r" [return]))) + (or last-kbd-macro + (y-or-n-p "No keyboard macro defined. Create one? ") + (keyboard-quit)) + (setq mac (or last-kbd-macro "")) + (setq cmd 'last-kbd-macro)) + ((eq cmd 'execute-extended-command) + (setq cmd (read-command "Name of keyboard macro to edit: ")) + (if (string-equal cmd "") + (error "No command name given")) + (setq mac (symbol-function cmd))) + ((eq cmd 'view-lossage) + (setq mac (recent-keys)) + (setq cmd 'last-kbd-macro)) + ((null cmd) + (error "Key sequence %s is not defined" (key-description keys))) + ((symbolp cmd) + (setq mac (symbol-function cmd))) + (t + (setq mac cmd) + (setq cmd nil))) + (unless (arrayp mac) + (error "Key sequence %s is not a keyboard macro" + (key-description keys))) + (message "Formatting keyboard macro...") + (let* ((oldbuf (current-buffer)) + (mmac (edmacro-fix-menu-commands mac)) + (fmt (edmacro-format-keys mmac 1)) + (fmtv (edmacro-format-keys mmac (not prefix))) + (buf (get-buffer-create "*Edit Macro*"))) + (message "Formatting keyboard macro...done") + (switch-to-buffer buf) + (kill-all-local-variables) + (use-local-map edmacro-mode-map) + (setq buffer-read-only nil) + (setq major-mode 'edmacro-mode) + (setq mode-name "Edit Macro") + (set (make-local-variable 'edmacro-original-buffer) oldbuf) + (set (make-local-variable 'edmacro-finish-hook) finish-hook) + (set (make-local-variable 'edmacro-store-hook) store-hook) + (erase-buffer) + (insert ";; Keyboard Macro Editor. Press C-c C-c to finish; " + "press C-x k RET to cancel.\n") + (insert ";; Original keys: " fmt "\n") + (unless store-hook + (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n") + (let ((keys (where-is-internal (or cmd mac)))) + (if keys + (while keys + (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n")) + (insert "Key: none\n")))) + (insert "\nMacro:\n\n") + (save-excursion + (insert fmtv "\n")) + (recenter '(4)) + (when (eq mac mmac) + (set-buffer-modified-p nil)) + (run-hooks 'edmacro-format-hook))))) + +;;; The next two commands are provided for convenience and backward +;;; compatibility. + +;;;###autoload +(defun edit-last-kbd-macro (&optional prefix) + "Edit the most recently defined keyboard macro." + (interactive "P") + (edit-kbd-macro 'call-last-kbd-macro prefix)) + +;;;###autoload +(defun edit-named-kbd-macro (&optional prefix) + "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'." + (interactive "P") + (edit-kbd-macro 'execute-extended-command prefix)) + +;;;###autoload +(defun read-kbd-macro (start &optional end) + "Read the region as a keyboard macro definition. +The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\". +See documentation for `edmacro-mode' for details. +Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored. +The resulting macro is installed as the \"current\" keyboard macro. + +In Lisp, may also be called with a single STRING argument in which case +the result is returned rather than being installed as the current macro. +The result will be a string if possible, otherwise an event vector. +Second argument NEED-VECTOR means to return an event vector always." + (interactive "r") + (if (stringp start) + (edmacro-parse-keys start end) + (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end))))) + +;;;###autoload +(defun format-kbd-macro (&optional macro verbose) + "Return the keyboard macro MACRO as a human-readable string. +This string is suitable for passing to `read-kbd-macro'. +Second argument VERBOSE means to put one command per line with comments. +If VERBOSE is `1', put everything on one line. If VERBOSE is omitted +or nil, use a compact 80-column format." + (and macro (symbolp macro) (setq macro (symbol-function macro))) + (edmacro-format-keys (or macro last-kbd-macro) verbose)) + +;;; Commands for *Edit Macro* buffer. + +(defun edmacro-finish-edit () + (interactive) + (unless (eq major-mode 'edmacro-mode) + (error + "This command is valid only in buffers created by `edit-kbd-macro'")) + (run-hooks 'edmacro-finish-hook) + (let ((cmd nil) (keys nil) (no-keys nil) + (top (point-min))) + (goto-char top) + (let ((case-fold-search nil)) + (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)") + t) + ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$") + (when edmacro-store-hook + (error "\"Command\" line not allowed in this context")) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (unless (equal str "") + (setq cmd (and (not (equal str "none")) + (intern str))) + (and (fboundp cmd) (not (arrayp (symbol-function cmd))) + (not (y-or-n-p + (format "Command %s is already defined; %s" + cmd "proceed? "))) + (keyboard-quit)))) + t) + ((looking-at "Key:\\(.*\\)$") + (when edmacro-store-hook + (error "\"Key\" line not allowed in this context")) + (let ((key (edmacro-parse-keys + (buffer-substring (match-beginning 1) + (match-end 1))))) + (unless (equal key "") + (if (equal key "none") + (setq no-keys t) + (push key keys) + (let ((b (key-binding key))) + (and b (commandp b) (not (arrayp b)) + (or (not (fboundp b)) + (not (arrayp (symbol-function b)))) + (not (y-or-n-p + (format "Key %s is already defined; %s" + (edmacro-format-keys key 1) + "proceed? "))) + (keyboard-quit)))))) + t) + ((looking-at "Macro:[ \t\n]*") + (goto-char (match-end 0)) + nil) + ((eobp) nil) + (t (error "Expected a `Macro:' line"))) + (forward-line 1)) + (setq top (point))) + (let* ((buf (current-buffer)) + (str (buffer-substring top (point-max))) + (modp (buffer-modified-p)) + (obuf edmacro-original-buffer) + (store-hook edmacro-store-hook) + (finish-hook edmacro-finish-hook)) + (unless (or cmd keys store-hook (equal str "")) + (error "No command name or keys specified")) + (when modp + (when (buffer-name obuf) + (set-buffer obuf)) + (message "Compiling keyboard macro...") + (let ((mac (edmacro-parse-keys str))) + (message "Compiling keyboard macro...done") + (if store-hook + (funcall store-hook mac) + (when (eq cmd 'last-kbd-macro) + (setq last-kbd-macro (and (> (length mac) 0) mac)) + (setq cmd nil)) + (when cmd + (if (= (length mac) 0) + (fmakunbound cmd) + (fset cmd mac))) + (if no-keys + (when cmd + (loop for key in (where-is-internal cmd '(keymap)) do + (global-unset-key key))) + (when keys + (if (= (length mac) 0) + (loop for key in keys do (global-unset-key key)) + (loop for key in keys do + (global-set-key key (or cmd mac))))))))) + (kill-buffer buf) + (when (buffer-name obuf) + (switch-to-buffer obuf)) + (when finish-hook + (funcall finish-hook))))) + +(defun edmacro-insert-key (key) + "Insert the written name of a key in the buffer." + (interactive "kKey to insert: ") + (if (bolp) + (insert (edmacro-format-keys key t) "\n") + (insert (edmacro-format-keys key) " "))) + +(defun edmacro-mode () + "\\Keyboard Macro Editing mode. Press +\\[edmacro-finish-edit] to save and exit. +To abort the edit, just kill this buffer with \\[kill-buffer] RET. + +Press \\[edmacro-insert-key] to insert the name of any key by typing the key. + +The editing buffer contains a \"Command:\" line and any number of +\"Key:\" lines at the top. These are followed by a \"Macro:\" line +and the macro itself as spelled-out keystrokes: `C-x C-f foo RET'. + +The \"Command:\" line specifies the command name to which the macro +is bound, or \"none\" for no command name. Write \"last-kbd-macro\" +to refer to the current keyboard macro (as used by \\[call-last-kbd-macro]). + +The \"Key:\" lines specify key sequences to which the macro is bound, +or \"none\" for no key bindings. + +You can edit these lines to change the places where the new macro +is stored. + + +Format of keyboard macros during editing: + +Text is divided into \"words\" separated by whitespace. Except for +the words described below, the characters of each word go directly +as characters of the macro. The whitespace that separates words +is ignored. Whitespace in the macro must be written explicitly, +as in \"foo SPC bar RET\". + + * The special words RET, SPC, TAB, DEL, LFD, ESC, and NUL represent + special control characters. The words must be written in uppercase. + + * A word in angle brackets, e.g., , , or , represents + a function key. (Note that in the standard configuration, the + function key and the control key RET are synonymous.) + You can use angle brackets on the words RET, SPC, etc., but they + are not required there. + + * Keys can be written by their ASCII code, using a backslash followed + by up to six octal digits. This is the only way to represent keys + with codes above \\377. + + * One or more prefixes M- (meta), C- (control), S- (shift), A- (alt), + H- (hyper), and s- (super) may precede a character or key notation. + For function keys, the prefixes may go inside or outside of the + brackets: C- = . The prefixes may be written in + any order: M-C-x = C-M-x. + + Prefixes are not allowed on multi-key words, e.g., C-abc, except + that the Meta prefix is allowed on a sequence of digits and optional + minus sign: M--123 = M-- M-1 M-2 M-3. + + * The `^' notation for control characters also works: ^M = C-m. + + * Double angle brackets enclose command names: <> is + shorthand for M-x next-line RET. + + * Finally, REM or ;; causes the rest of the line to be ignored as a + comment. + +Any word may be prefixed by a multiplier in the form of a decimal +number and `*': 3* = , and +10*foo = foofoofoofoofoofoofoofoofoofoo. + +Multiple text keys can normally be strung together to form a word, +but you may need to add whitespace if the word would look like one +of the above notations: `; ; ;' is a keyboard macro with three +semicolons, but `;;;' is a comment. Likewise, `\\ 1 2 3' is four +keys but `\\123' is a single key written in octal, and `< right >' +is seven keys but `' is a single function key. When in +doubt, use whitespace." + (interactive) + (error "This mode can be enabled only by `edit-kbd-macro'")) +(put 'edmacro-mode 'mode-class 'special) + + +(defun edmacro-int-char (int) + (if (fboundp 'char-to-int) + (char-to-int int) + int)) + +;;; Formatting a keyboard macro as human-readable text. + +;; Changes for XEmacs -- these two functions re-written from scratch. +;; edmacro-parse-keys always returns a vector. edmacro-format-keys +;; accepts a vector (but works with a string too). Vector may contain +;; keypress events. -hniksic +(defun edmacro-parse-keys (string &optional ignored) + (let ((pos 0) + (case-fold-search nil) + (word-to-sym '(("NUL" . (control space)) + ("RET" . return) + ("LFD" . linefeed) + ("TAB" . tab) + ("ESC" . escape) + ("SPC" . space) + ("BS" . backspace) + ("DEL" . delete))) + (char-to-word '((?\0 . "NUL") + (?\r . "RET") + (?\n . "LFD") + (?\t . "TAB") + (?\e . "ESC") + (?\ . "SPC") + (?\C-? . "DEL"))) + ;; string-to-symbol-or-char converter + (conv #'(lambda (arg) + (if (= (length arg) 1) + (aref arg 0) + (if (string-match "^<\\([^>]+\\)>$" arg) + (setq arg (match-string 1 arg))) + (let ((match (assoc arg word-to-sym))) + (if match + (cdr match) + (intern arg)))))) + (conv-chars #'(lambda (arg) + (let ((match (assoc arg char-to-word))) + (if match + (cdr (assoc (cdr match) word-to-sym)) + arg)))) + (force-sym nil) + res word found) + (while (and (< pos (length string)) + (string-match "[^ \t\n\f]+" string pos)) + (let ((word (substring string (match-beginning 0) (match-end 0))) + (times 1) + (add nil)) + (setq pos (match-end 0)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-int (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (when (string-match "^<\\([^>]+\\)>$" word) + (setq word (match-string 1 word)) + (setq force-sym t)) + (setq match (assoc word word-to-sym)) + ;; Add an element. + (cond ((string-match "^\\\\[0-7]+" word) + ;; Octal value of character. + (setq add + (list + (edmacro-int-char (string-to-int (substring word 1)))))) + ((string-match "^<<.+>>$" word) + ;; Extended command. + (setq add + (nconc + (list + (if (eq (key-binding [(meta x)]) + 'execute-extended-command) + '(meta x) + (or (car (where-is-internal + 'execute-extended-command)) + '(meta x)))) + (mapcar conv-chars (concat (substring word 2 -2) "\r"))) + )) + ((or (equal word "REM") (string-match "^;;" word)) + ;; Comment. + (setq pos (string-match "$" string pos))) + (match + ;; Convert to symbol. + (setq add (list (cdr match)))) + ((string-match "^\\^" word) + ;; ^X == C-x + (if (/= (length word) 2) + (error "^ must be followed by one character")) + (setq add `((control ,(aref word 0))))) + ((string-match "^[MCSsAH]-" word) + ;; Parse C-* + (setq + add + (list + (let ((pos1 0) + (r1 nil) + follow) + (while (string-match "^[MCSsAH]-" (substring word pos1)) + (setq r1 (nconc + r1 + (list + (cdr (assq (aref word pos1) + '((?C . control) + (?M . meta) + (?S . shift) + (?A . alt) + (?H . hyper) + (?s . super))))))) + (setq pos1 (+ pos1 2))) + (setq follow (substring word pos1)) + (if (equal follow "") + (error "%s must precede a string" + (substring word 0 pos1))) + (nconc r1 (list (funcall conv follow))))))) + (force-sym + ;; This must be a symbol + (setq add (list (intern word)))) + (t + ;; Characters + (setq add (mapcar conv-chars word)))) + (let ((new nil)) + (loop repeat times do (setq new (append new add))) + (setq add new)) + (setq res (nconc res add)))) + (mapvector 'identity res))) + +(defun edmacro-conv (char-or-sym add-<>) + (let ((char-to-word '((?\0 . "NUL") + (?\r . "RET") + (?\n . "LFD") + (?\t . "TAB") + (?\e . "ESC") + (?\ . "SPC") + (?\C-? . "DEL"))) + (symbol-to-char '((return . ?\r) + (space . ?\ ) + (delete . ?\C-?) + (tab . ?\t) + (escape . ?\e)))) + (if (symbolp char-or-sym) + (if (= (length (symbol-name char-or-sym)) 1) + (setq char-or-sym (aref (symbol-name char-or-sym) 0)) + (let ((found (assq char-or-sym symbol-to-char))) + (if found + (setq char-or-sym (cdr found)))))) + ;; Return: + (cons (symbolp char-or-sym) + (if (symbolp char-or-sym) + (if add-<> + (concat "<" (symbol-name char-or-sym) ">") + (symbol-name char-or-sym)) + (let ((found (assq char-or-sym char-to-word))) + (if found + (cdr found) + (single-key-description char-or-sym))))))) + +(defun edmacro-format-1 (keys command times togetherp) + (let ((res "") + (start keys) + el) + (while keys + (unless (or (eq start keys) togetherp) + (callf concat res " ")) + (if (> times 1) + (setq res (concat (format "%d*" times) res))) + (setq el (car keys)) + (callf concat res + (cond ((listp el) + (let ((my "")) + (if (or + (let (cnv) + (while el + (let ((found (assq (car el) + '((control . "C-") + (meta . "M-") + (shift . "S-") + (alt . "A-") + (hyper . "H-") + (super . "s-"))))) + (callf concat my + (if found + (cdr found) + (setq cnv (edmacro-conv (car el) nil)) + (cdr cnv)))) + (setq el (cdr el))) + (car cnv)) + (> times 1)) + (concat "<" my ">") + my))) + (t + (cdr (edmacro-conv el t))))) + (setq keys (cdr keys))) + (if command + (callf concat res + (concat + (make-string (max (- 3 (/ (length res) tab-width)) 1) ?\t) + ";; " + (symbol-name command) + (if togetherp (format " * %d" (length start)))))) + res)) + +(defun edmacro-format-keys (macro &optional verbose) + (let ((cnt 0) + (res "")) + ;; XEmacs: + ;; If we're dealing with events, convert them to symbols first. + (and (fboundp 'events-to-keys) + (eventp (aref macro 0)) + (setq macro (events-to-keys macro t))) + + ;; I'm not sure I understand the original code, but this seems to + ;; work. + (and (eq verbose 1) + (setq verbose nil)) + + ;; Oh come on -- I want a list! Much easier to process... + (setq macro (mapcar 'identity macro)) + + (while macro + (let (key lookup (times 1) self-insert-p) + (loop do + (setq key (nconc key (list (car macro))) + macro (cdr macro) + lookup (lookup-key global-map (mapvector 'identity key))) + while + (and lookup (not (commandp lookup)))) + (if (and (eq lookup 'self-insert-command) + (= (length key) 1) + (not (memq (car key) + '(?\ ?\r ?\n space return linefeed tab)))) + (while (and (< (length key) 23) + (eq (lookup-key global-map (car macro)) + 'self-insert-command) + (not (memq (car macro) + '(?\ ?\r ?\n space return linefeed tab)))) + (setq key (nconc key (list (car macro))) + macro (cdr macro) + self-insert-p t)) + (while (edmacro-seq-equal key macro) + (setq macro (nthcdr (length key) macro)) + (incf times))) + (if (or self-insert-p + (null (cdr key)) + (= times 1)) + (callf concat res (edmacro-format-1 key (if verbose lookup + nil) + times self-insert-p) + (if verbose "\n" " ")) + (loop repeat times + do + (callf concat res + (edmacro-format-1 key (if verbose lookup + nil) + 1 self-insert-p) + (if verbose "\n" " ")))) + )) + res)) + +(defun edmacro-seq-equal (seq1 seq2) + (while (and seq1 seq2 + (equal (car seq1) (car seq2))) + (setq seq1 (cdr seq1) + seq2 (cdr seq2))) + (not seq1)) + +(defun edmacro-fix-menu-commands (macro) + (when (vectorp macro) + (let ((i 0) ev) + (while (< i (length macro)) + (when (consp (setq ev (aref macro i))) + (cond ((equal (cadadr ev) '(menu-bar)) + (setq macro (vconcat (edmacro-subseq macro 0 i) + (vector 'menu-bar (car ev)) + (edmacro-subseq macro (1+ i)))) + (incf i)) + ;; It would be nice to do pop-up menus, too, but not enough + ;; info is recorded in macros to make this possible. + (t + (error "Macros with mouse clicks are not %s" + "supported by this command")))) + (incf i)))) + macro) + +;;; Parsing a human-readable keyboard macro. + + + +;;; The following probably ought to go in macros.el: + +;;;###autoload +(defun insert-kbd-macro (macroname &optional keys) + "Insert in buffer the definition of kbd macro NAME, as Lisp code. +Optional second arg KEYS means also record the keys it is on +\(this is the prefix argument, when calling interactively). + +This Lisp code will, when executed, define the kbd macro with the same +definition it has now. If you say to record the keys, the Lisp code +will also rebind those keys to the macro. Only global key bindings +are recorded since executing this Lisp code always makes global +bindings. + +To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +use this command, and then save the file." + (interactive "CInsert kbd macro (name): \nP") + (let (definition) + (if (string= (symbol-name macroname) "") + (progn + (setq definition (format-kbd-macro)) + (insert "(setq last-kbd-macro")) + (setq definition (format-kbd-macro macroname)) + (insert (format "(defalias '%s" macroname))) + (if (> (length definition) 50) + (insert " (read-kbd-macro\n") + (insert "\n (read-kbd-macro ")) + (prin1 definition (current-buffer)) + (insert "))\n") + (if keys + (let ((keys (where-is-internal macroname '(keymap)))) + (while keys + (insert (format "(global-set-key %S '%s)\n" (car keys) macroname)) + (setq keys (cdr keys))))))) + +(provide 'edmacro) + +;;; edmacro.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/utils/eldoc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/eldoc.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,533 @@ +;;; eldoc.el --- show function arglist or variable docstring in echo area + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Noah Friedman +;; Maintainer: friedman@prep.ai.mit.edu +;; Keywords: extensions +;; Created: 1995-10-06 + +;; $Id: eldoc.el,v 1.1 1997/02/14 19:59:51 steve Exp $ + +;; 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 program was inspired by the behavior of the "mouse documentation +;; window" on many Lisp Machine systems; as you type a function's symbol +;; name as part of a sexp, it will print the argument list for that +;; function. Behavior is not identical; for example, you need not actually +;; type the function name, you need only move point around in a sexp that +;; calls it. Also, if point is over a documented variable, it will print +;; the one-line documentation for that variable instead, to remind you of +;; that variable's meaning. + +;; One useful way to enable this minor mode is to put the following in your +;; .emacs: +;; +;; (autoload 'turn-on-eldoc-mode "eldoc" nil t) +;; (add-hook 'emacs-lisp-mode-hook 'turn-on-eldoc-mode) +;; (add-hook 'lisp-interaction-mode-hook 'turn-on-eldoc-mode) + +;;; Code: + +;; Use idle timers if available in the version of emacs running. +;; Please don't change this to use `require'; this package works as-is in +;; XEmacs (which doesn't have timer.el as of 19.14), and I would like to +;; maintain compatibility with that since I must use it sometimes. --Noah +(or (featurep 'timer) + (load "timer" t)) + +;;;###autoload +(defvar eldoc-mode nil + "*If non-nil, show the defined parameters for the elisp function near point. + +For the emacs lisp function at the beginning of the sexp which point is +within, show the defined parameters for the function in the echo area. +This information is extracted directly from the function or macro if it is +in pure lisp. If the emacs function is a subr, the parameters are obtained +from the documentation string if possible. + +If point is over a documented variable, print that variable's docstring +instead. + +This variable is buffer-local.") +(make-variable-buffer-local 'eldoc-mode) + +(defconst eldoc-idle-delay 0.50 + "*Number of seconds of idle time to wait before printing. +If user input arrives before this interval of time has elapsed after the +last input, no documentation will be printed. + +If this variable is set to 0, no idle time is required.") + +(defconst eldoc-minor-mode-string " ElDoc" + "*String to display in mode line when Eldoc Mode is enabled.") + +;; Put this minor mode on the global minor-mode-alist. +(or (assq 'eldoc-mode (default-value 'minor-mode-alist)) + (setq-default minor-mode-alist + (append (default-value 'minor-mode-alist) + '((eldoc-mode eldoc-minor-mode-string))))) + +(defconst eldoc-argument-case 'upcase + "Case to display argument names of functions, as a symbol. +This has two preferred values: `upcase' or `downcase'. +Actually, any name of a function which takes a string as an argument and +returns another string is acceptable.") + +(defvar eldoc-message-commands nil + "*Commands after which it is appropriate to print in the echo area. + +Eldoc does not try to print function arglists, etc. after just any command, +because some commands print their own messages in the echo area and these +functions would instantly overwrite them. But self-insert-command as well +as most motion commands are good candidates. + +This variable contains an obarray of symbols; it is probably best to +manipulate this data structure with the commands `eldoc-add-command' and +`eldoc-remove-command'.") + +(cond ((null eldoc-message-commands) + ;; If you increase the number of buckets, keep it a prime number. + (setq eldoc-message-commands (make-vector 31 0)) + (let ((list '("self-insert-command" + "next-" "previous-" + "forward-" "backward-" + "beginning-of-" "end-of-" + "goto-" + "recenter" + "scroll-" + "mouse-set-point")) + (syms nil)) + (while list + (setq syms (all-completions (car list) obarray 'fboundp)) + (setq list (cdr list)) + (while syms + (set (intern (car syms) eldoc-message-commands) t) + (setq syms (cdr syms))))))) + +;; Bookkeeping; the car contains the last symbol read from the buffer. +;; The cdr contains the string last displayed in the echo area, so it can +;; be printed again if necessary without reconsing. +(defvar eldoc-last-data '(nil . nil)) + +;; Idle timers are supported in Emacs 19.31 and later. +(defconst eldoc-use-idle-timer-p (fboundp 'run-with-idle-timer)) + +;; eldoc's timer object, if using idle timers +(defvar eldoc-timer nil) + +;; idle time delay currently in use by timer. +;; This is used to determine if eldoc-idle-delay is changed by the user. +(defvar eldoc-current-idle-delay eldoc-idle-delay) + +;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages are +;; recorded in a log. Do not put eldoc messages in that log since +;; they are Legion. +(defmacro eldoc-message (&rest args) + (if (fboundp 'display-message) + ;; XEmacs 19.13 way of preventing log messages. + (list 'display-message '(quote no-log) (apply 'list 'format args)) + (list 'let (list (list 'message-log-max 'nil)) + (apply 'list 'message args)))) + + +;;;###autoload +(defun eldoc-mode (&optional prefix) + "*Enable or disable eldoc mode. +See documentation for the variable of the same name for more details. + +If called interactively with no prefix argument, toggle current condition +of the mode. +If called with a positive or negative prefix argument, enable or disable +the mode, respectively." + (interactive "P") + + (cond (eldoc-use-idle-timer-p + (add-hook 'post-command-hook 'eldoc-schedule-timer)) + (t + ;; Use post-command-idle-hook if defined, otherwise use + ;; post-command-hook. The former is only proper to use in Emacs + ;; 19.30; that is the first version in which it appeared, but it + ;; was obsolesced by idle timers in Emacs 19.31. + (add-hook (if (boundp 'post-command-idle-hook) + 'post-command-idle-hook + 'post-command-hook) + 'eldoc-print-current-symbol-info))) + + (setq eldoc-mode (if prefix + (>= (prefix-numeric-value prefix) 0) + (not eldoc-mode))) + + (and (interactive-p) + (if eldoc-mode + (message "eldoc-mode is enabled") + (message "eldoc-mode is disabled"))) + eldoc-mode) + +;;;###autoload +(defun turn-on-eldoc-mode () + "Unequivocally turn on eldoc-mode (see variable documentation)." + (interactive) + (eldoc-mode 1)) + +(defun eldoc-add-command (cmd) + "Add COMMAND to the list of commands which causes function arg display. +If called interactively, completion on defined commands is available. + +When point is in a sexp, the function args are not reprinted in the echo +area after every possible interactive command because some of them print +their own messages in the echo area; the eldoc functions would instantly +overwrite them unless it is more restrained." + (interactive "CAdd function to eldoc message commands list: ") + (and (fboundp cmd) + (set (intern (symbol-name cmd) eldoc-message-commands) t))) + +(defun eldoc-remove-command (cmd) + "Remove COMMAND from the list of commands which causes function arg display. +If called interactively, completion matches only those functions currently +in the list. + +When point is in a sexp, the function args are not reprinted in the echo +area after every possible interactive command because some of them print +their own messages in the echo area; the eldoc functions would instantly +overwrite them unless it is more restrained." + (interactive (list (completing-read + "Remove function from eldoc message commands list: " + eldoc-message-commands 'boundp t))) + (and (symbolp cmd) + (setq cmd (symbol-name cmd))) + (if (fboundp 'unintern) + (unintern cmd eldoc-message-commands) + (let ((s (intern-soft cmd eldoc-message-commands))) + (and s + (makunbound s))))) + +;; Idle timers are part of Emacs 19.31 and later. +(defun eldoc-schedule-timer () + (or (and eldoc-timer + (memq eldoc-timer timer-idle-list)) + (setq eldoc-timer + (run-with-idle-timer eldoc-idle-delay t + 'eldoc-print-current-symbol-info))) + + ;; If user has changed the idle delay, update the timer. + (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) + (setq eldoc-current-idle-delay eldoc-idle-delay) + (timer-set-idle-time eldoc-timer eldoc-idle-delay t)))) + + +(defun eldoc-print-current-symbol-info () + (and eldoc-mode + (not executing-kbd-macro) + + ;; Having this mode operate in an active minibuffer makes it + ;; impossible to see what you're doing. + (not (eq (selected-window) (minibuffer-window))) + + (cond (eldoc-use-idle-timer-p + (and (symbolp last-command) + (intern-soft (symbol-name last-command) + eldoc-message-commands))) + (t + ;; If we don't have idle timers, this function is + ;; running on post-command-hook directly; that means the + ;; user's last command is still on `this-command', and we + ;; must wait briefly for input to see whether to do display. + (and (symbolp this-command) + (intern-soft (symbol-name this-command) + eldoc-message-commands) + (sit-for eldoc-idle-delay)))) + + (let ((current-symbol (eldoc-current-symbol)) + (current-fnsym (eldoc-fnsym-in-current-sexp))) + (cond ((eq current-symbol current-fnsym) + (eldoc-print-fnsym-args current-fnsym)) + (t + (or (eldoc-print-var-docstring current-symbol) + (eldoc-print-fnsym-args current-fnsym))))))) + +(defun eldoc-print-fnsym-args (&optional symbol) + (interactive) + (let ((sym (or symbol (eldoc-fnsym-in-current-sexp))) + (args nil)) + (cond ((not (and (symbolp sym) + (fboundp sym)))) + ((eq sym (car eldoc-last-data)) + (setq args (cdr eldoc-last-data))) + ((subrp (eldoc-symbol-function sym)) + (setq args (or (eldoc-function-argstring-from-docstring sym) + (eldoc-docstring-first-line (documentation sym t)))) + (setcar eldoc-last-data sym) + (setcdr eldoc-last-data args)) + (t + (setq args (eldoc-function-argstring sym)) + (setcar eldoc-last-data sym) + (setcdr eldoc-last-data args))) + (and args + (eldoc-message "%s: %s" sym args)))) + +(defun eldoc-fnsym-in-current-sexp () + (let* ((p (point)) + (sym (progn + (while (and (eldoc-forward-sexp-safe -1) + (> (point) (point-min)))) + (cond ((or (= (point) (point-min)) + (memq (or (char-after (point)) 0) + '(?\( ?\")) + ;; If we hit a quotation mark before a paren, we + ;; are inside a specific string, not a list of + ;; symbols. + (eq (or (char-after (1- (point))) 0) ?\")) + nil) + (t (condition-case nil + (read (current-buffer)) + (error nil))))))) + (goto-char p) + (and (symbolp sym) + sym))) + +(defun eldoc-function-argstring (fn) + (let* ((prelim-def (eldoc-symbol-function fn)) + (def (if (eq (car-safe prelim-def) 'macro) + (cdr prelim-def) + prelim-def)) + (arglist (cond ((null def) nil) + ((byte-code-function-p def) + (if (fboundp 'compiled-function-arglist) + (funcall 'compiled-function-arglist def) + (aref def 0))) + ((eq (car-safe def) 'lambda) + (nth 1 def)) + (t t)))) + (eldoc-function-argstring-format arglist))) + +(defun eldoc-function-argstring-format (arglist) + (cond ((not (listp arglist)) + (setq arglist nil)) + ((symbolp (car arglist)) + (setq arglist + (mapcar (function (lambda (s) + (if (memq s '(&optional &rest)) + (symbol-name s) + (funcall eldoc-argument-case + (symbol-name s))))) + arglist))) + ((stringp (car arglist)) + (setq arglist + (mapcar (function (lambda (s) + (if (member s '("&optional" "&rest")) + s + (funcall eldoc-argument-case s)))) + arglist)))) + (concat "(" (mapconcat 'identity arglist " ") ")")) + + +(defun eldoc-print-var-docstring (&optional sym) + (or sym (setq sym (eldoc-current-symbol))) + (eldoc-print-docstring sym (documentation-property + sym 'variable-documentation t))) + +;; Print the brief (one-line) documentation string for the symbol. +(defun eldoc-print-docstring (symbol doc) + (and doc + (eldoc-message "%s" (eldoc-docstring-message symbol doc)))) + +;; If the entire line cannot fit in the echo area, the variable name may be +;; truncated or eliminated entirely from the output to make room. +;; Any leading `*' in the docstring (which indicates the variable is a user +;; option) is not printed." +(defun eldoc-docstring-message (symbol doc) + (and doc + (let ((name (symbol-name symbol))) + (setq doc (eldoc-docstring-first-line doc)) + (save-match-data + (let* ((doclen (+ (length name) (length ": ") (length doc))) + ;; Subtract 1 from window width since emacs seems not to + ;; write any chars to the last column, at least for some + ;; terminal types. + (strip (- doclen (1- (window-width (minibuffer-window)))))) + (cond ((> strip 0) + (let* ((len (length name))) + (cond ((>= strip len) + (format "%s" doc)) + (t + (setq name (substring name 0 (- len strip))) + (format "%s: %s" name doc))))) + (t + (format "%s: %s" symbol doc)))))))) + +(defun eldoc-docstring-first-line (doc) + (save-match-data + (and (string-match "\n" doc) + (setq doc (substring doc 0 (match-beginning 0)))) + (and (string-match "^\\*" doc) + (setq doc (substring doc 1)))) + doc) + + +;; Alist of predicate/action pairs. +;; Each member of the list is a sublist consisting of a predicate function +;; used to determine if the arglist for a function can be found using a +;; certain pattern, and a function which returns the actual arglist from +;; that docstring. +;; +;; The order in this table is significant, since later predicates may be +;; more general than earlier ones. +;; +;; Compiler note for Emacs 19.29 and later: these functions will be +;; compiled to bytecode, but can't be lazy-loaded even if you set +;; byte-compile-dynamic; to do that would require making them named +;; top-level defuns, and that's not particularly desirable either. +(defconst eldoc-function-argstring-from-docstring-method-table + (list + ;; Try first searching for args starting with symbol name. + ;; This is to avoid matching parenthetical remarks in e.g. sit-for. + (list (function (lambda (doc fn) + (string-match (format "^(%s[^\n)]*)$" fn) doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 0) 1))) + (if (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end) + ""))))) + + ;; Try again not requiring this symbol name in the docstring. + ;; This will be the case when looking up aliases. + (list (function (lambda (doc fn) + (string-match "^([^\n)]+)$" doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 0) 1))) + (and (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end)))))) + + ;; Emacs subr docstring style: + ;; (fn arg1 arg2 ...): description... + (list (function (lambda (doc fn) + (string-match "^([^\n)]+):" doc))) + (function (lambda (doc) + ;; end does not include trailing "):" sequence. + (let ((end (- (match-end 0) 2))) + (and (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end)))))) + + ;; XEmacs subr docstring style: + ;; "arguments: (arg1 arg2 ...) + (list (function (lambda (doc fn) + (string-match "^arguments: (\\([^\n)]+\\))" doc))) + (function (lambda (doc) + ;; also skip leading paren, but the first word is + ;; actually an argument, not the function name. + (substring doc (match-beginning 1) (match-end 1))))) + + ;; This finds the argstring for `condition-case'. Any others? + (list (function (lambda (doc fn) + (string-match + (format "^Usage looks like \\((%s[^\n)]*)\\)\\.$" fn) + doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 1) 1))) + (and (string-match " +" doc (match-beginning 1)) + (substring doc (match-end 0) end)))))) + + ;; This finds the argstring for `setq-default'. Any others? + (list (function (lambda (doc fn) + (string-match (format "^[ \t]+\\((%s[^\n)]*)\\)$" fn) + doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 1) 1))) + (and (string-match " +" doc (match-beginning 1)) + (substring doc (match-end 0) end)))))) + + ;; This finds the argstring for `start-process'. Any others? + (list (function (lambda (doc fn) + (string-match "^Args are +\\([^\n]+\\)$" doc))) + (function (lambda (doc) + (substring doc (match-beginning 1) (match-end 1))))) + )) + +(defun eldoc-function-argstring-from-docstring (fn) + (let ((docstring (documentation fn 'raw)) + (table eldoc-function-argstring-from-docstring-method-table) + (doc nil) + (doclist nil)) + (save-match-data + (while table + (cond ((funcall (car (car table)) docstring fn) + (setq doc (funcall (car (cdr (car table))) docstring)) + (setq table nil)) + (t + (setq table (cdr table))))) + + (cond ((not (stringp doc)) + nil) + ((string-match "&" doc) + (let ((p 0) + (l (length doc))) + (while (< p l) + (cond ((string-match "[ \t\n]+" doc p) + (setq doclist + (cons (substring doc p (match-beginning 0)) + doclist)) + (setq p (match-end 0))) + (t + (setq doclist (cons (substring doc p) doclist)) + (setq p l)))) + (eldoc-function-argstring-format (nreverse doclist)))) + (t + (concat "(" (funcall eldoc-argument-case doc) ")")))))) + + +;; forward-sexp calls scan-sexps, which returns an error if it hits the +;; beginning or end of the sexp. This returns nil instead. +(defun eldoc-forward-sexp-safe (&optional count) + "Move forward across one balanced expression (sexp). +With argument, do it that many times. Negative arg -COUNT means +move backward across COUNT balanced expressions. +Return distance in buffer moved, or nil." + (or count (setq count 1)) + (condition-case err + (- (- (point) (progn + (let ((parse-sexp-ignore-comments t)) + (forward-sexp count)) + (point)))) + (error nil))) + +;; Do indirect function resolution if possible. +(defun eldoc-symbol-function (fsym) + (let ((defn (and (fboundp fsym) + (symbol-function fsym)))) + (and (symbolp defn) + (condition-case err + (setq defn (indirect-function fsym)) + (error (setq defn nil)))) + defn)) + +(defun eldoc-current-symbol () + (let ((c (char-after (point)))) + (and c + (memq (char-syntax c) '(?w ?_)) + (intern-soft (current-word))))) + +(provide 'eldoc) + +;;; eldoc.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/utils/floating-toolbar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/floating-toolbar.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,378 @@ +;;; floating-toolbar.el -- popup toolbar support for XEmacs. +;; Copyright (C) 1997 Kyle E. Jones + +;; Author: Kyle Jones +;; Keywords: lisp + +;; 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 +;; the Free Software Foundation; either version 1, 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. + +;; A copy of the GNU General Public License can be obtained from this +;; program's author (send electronic mail to kyle@uunet.uu.net) or from +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Popup toolbar for XEmacs (probably require XEmacs 19.14 or later) +;; Send bug reports to kyle_jones@wonderworks.com + +;; The command `floating-toolbar' pops up a small frame +;; containing a toolbar. The command should be bound to a +;; button-press event. If the mouse press happens over an +;; extent that has a non-nil 'floating-toolbar property, the +;; value of that property is the toolbar instantiator that will +;; be displayed. Otherwise the toolbar displayed is taken from +;; the variable `floating-toolbar'. This variable can be made +;; buffer local to produce buffer local floating toolbars. +;; +;; `floating-toolbar-or-popup-mode-menu' works like `floating-toolbar' +;; except that if no toolbar is found, `popup-mode-menu' is called. +;; +;; `floating-toolbar-from-extent-or-popup-mode-menu' works like +;; `floating-toolbar-or-popup-mode-menu' except only extent local +;; toolbars are used; the value of floating-toolbar is not used. +;; +;; Installation: +;; +;; Byte-compile the file floating-toolbar.el (with M-x byte-compile-file) +;; and put the .elc file in a directory in your load-path. Add the +;; following line to your .emacs: +;; +;; (require 'floating-toolbar) +;; +;; You will also need to bind a mouse click to `floating-toolbar' or to +;; `floating-toolbar-or-popup-mode-menu'. +;; +;; For 19.12 users: +;; If you are using fvwm, [tv]twm or ol[v]wm, you can also add +;; the following lines to various configuration file to use +;; minimal decorations on the toolbar frame. +;; +;; In .emacs: +;; (setq floating-toolbar-frame-name "floating-toolbar") +;; +;; For ol[v]wm use this in .Xdefaults: +;; olvwm.NoDecor: floating-toolbar +;; or +;; olwm.MinimalDecor: floating-toolbar +;; +;; For fvvm use this in your .fvwmrc: +;; NoTitle floating-toolbar +;; or +;; Style "floating-toolbar" NoTitle, NoHandles, BorderWidth 0 +;; +;; For twm use this in your .twmrc: +;; NoTitle { "floating-toolbar" } +;; +;; Under 19.13 and later versions the floating-toolbar frame uses a +;; transient window that is not normally decorated by window +;; managers. So the window manager directives should not be +;; needed for XEmacs 19.13 and beyond. + +;;; Code: + +(provide 'floating-toolbar) + +(require 'toolbar) +(require 'x) + +(defvar floating-toolbar-version "1.01" + "Version string for the floating-toolbar package.") + +(defvar floating-toolbar-use-sound nil + "*Non-nil value means play a sound to herald the appearance +and disappearance of the floating toolbar. + +`floating-toolbar-appears' will be played when the toolbar appears. +`floating-toolbar-disappears' will be played when the toolbar disappears. + +See the documentation for the function `load-sound-file' to see how +define sounds.") + +(defvar floating-toolbar nil + "*Toolbar instantiator used if mouse event is not over an extent +with a non-nil 'floating-toolbar property. This variable can be +made local to a buffer to have buffer local floating toolbars.") + +(defvar floating-toolbar-help-font nil + "*Non-nil value should be a font to be used to display toolbar help +messages. The floating toolbar frame will have a minibuffer window +so that it can display any help text that is attached to the toolbar +buttons.") + +(defvar floating-toolbar-frame-name nil + "*The frame name for the frame used to display the floating toolbar.") + +;;; +;;; End of user variables. +;;; + +(defvar floating-toolbar-frame nil + "The floating toolbar is displayed in this frame.") + +(defvar floating-toolbar-display-pending nil + "Non-nil value means the toolbar frame will be visible as soon +as the X server gets around to displaying it. Nil means it +will be invisible as soon as the X server decides to hide it.") + +(defun floating-toolbar-displayed () + (and (frame-live-p floating-toolbar-frame) + (frame-visible-p floating-toolbar-frame))) + +;;;###autoload +(defun floating-toolbar (event &optional extent-local-only) + "Popup a toolbar near the current mouse position. +The toolbar instantiator used is taken from the 'floating-toolbar +property of any extent under the mouse. If no such non-nil +property exists for any extent under the mouse, then the value of the +variable `floating-toolbar' is checked. If its value si nil, then +no toolbar will be displayed. + +This command should be bound to a button press event. + +When called from a program, first arg EVENT should be the button +press event. Optional second arg EXTENT-LOCAL-ONLY specifies +that only extent local toolbars should be used; this means the +`floating-toolbar' variable will not be consulted." + (interactive "_e") + (if (not (mouse-event-p event)) + nil + (let* ((buffer (event-buffer event)) + (window (event-window event)) + (frame (event-frame event)) + (point (and buffer (event-point event))) + (glyph-extent (event-glyph-extent event)) + (glyph-extent (if (and glyph-extent + (extent-property glyph-extent + 'floating-toolbar)) + glyph-extent)) + (extent (or glyph-extent + (and point + (extent-at point buffer 'floating-toolbar)))) + (toolbar (or (and extent (get extent 'floating-toolbar)) + (and (not extent-local-only) + (symbol-value-in-buffer 'floating-toolbar + buffer nil)))) + (x nil) + (y nil) + (echo-keystrokes 0) + (awaiting-release t) + (done nil)) + (if (not (consp toolbar)) + nil + ;; event-[xy]-pixel are relative to the top left corner + ;; of the frame. The presence of top and left toolbar + ;; and the menubar can move this position down and + ;; leftward, but XEmacs doesn't compensate for this in + ;; the values returned. So we do it here, as best we + ;; can. + (let* ((params (frame-parameters frame)) + (top (cdr (assq 'top params))) + (left (cdr (assq 'left params))) + (xtop-toolbar-height + (if (specifier-instance top-toolbar) + (specifier-instance top-toolbar-height) + 0)) + (xleft-toolbar-width + (if (specifier-instance left-toolbar) + (specifier-instance left-toolbar-width) + 0)) + ;; better than nothing + (menubar-height (if current-menubar 22 0))) + (setq x (+ left xleft-toolbar-width (event-x-pixel event)) + y (+ top xtop-toolbar-height menubar-height + (event-y-pixel event)))) + ;; for toolbar spec buffer local variable values + (and buffer (set-buffer buffer)) + (floating-toolbar-display-toolbar toolbar x y) + (while (not done) + (setq event (next-command-event)) + (cond ((and awaiting-release (button-release-event-p event)) + (setq awaiting-release nil)) + ((and (button-release-event-p event) + (event-over-toolbar-p event) + (eq floating-toolbar-frame (event-frame event))) + (floating-toolbar-undisplay-toolbar) + (and window (select-frame (window-frame window))) + (and window (select-window window)) + (dispatch-event event) + (setq done t)) + ((and (button-press-event-p event) + (event-over-toolbar-p event) + (eq floating-toolbar-frame (event-frame event))) + (setq awaiting-release nil) + (dispatch-event event)) + (t + ;; push back the event if it was in another frame. + ;; eat it if it was in the toolbar frame. + (if (and (event-frame event) + (not (eq floating-toolbar-frame + (event-frame event)))) + (setq unread-command-events + (cons event unread-command-events))) + (floating-toolbar-undisplay-toolbar) + (setq done t)))) + t )))) + +;;;###autoload +(defun floating-toolbar-or-popup-mode-menu (event) + "Like floating-toolbar, but if no toolbar is displayed +run popup-mode-menu." + (interactive "_e") + (or (floating-toolbar event) (popup-mode-menu))) + +;;;###autoload +(defun floating-toolbar-from-extent-or-popup-mode-menu (event) + "Like floating-toolbar-or-popup-mode-menu, but search only for an +extent local toolbar." + (interactive "_e") + (or (floating-toolbar event t) (popup-mode-menu))) + +(defun floating-toolbar-display-toolbar (toolbar x y) + (if (not (frame-live-p floating-toolbar-frame)) + (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame x y))) + (set-specifier top-toolbar + (cons (window-buffer + (frame-selected-window floating-toolbar-frame)) + toolbar)) + (floating-toolbar-resize-toolbar-frame toolbar) + ;; fiddle with the x value to try to center the toolbar relative to + ;; the mouse position. + (setq x (max 0 (- x (/ (frame-pixel-width floating-toolbar-frame) 2)))) + (floating-toolbar-set-toolbar-frame-position x y) + (floating-toolbar-expose-toolbar-frame)) + +(defun floating-toolbar-undisplay-toolbar () + (floating-toolbar-hide-toolbar-frame)) + +(defun floating-toolbar-hide-toolbar-frame () + (if (floating-toolbar-displayed) + (progn + (make-frame-invisible floating-toolbar-frame) + (if (and floating-toolbar-use-sound floating-toolbar-display-pending) + (play-sound 'floating-toolbar-disappears)) + (setq floating-toolbar-display-pending nil)))) + +(defun floating-toolbar-expose-toolbar-frame () + (if (not (floating-toolbar-displayed)) + (progn + (make-frame-visible floating-toolbar-frame) + (if (and floating-toolbar-use-sound + (null floating-toolbar-display-pending)) + (play-sound 'floating-toolbar-appears)) + (setq floating-toolbar-display-pending t)))) + +(defun floating-toolbar-resize-toolbar-frame (toolbar) + (let ((width 0) + (height nil) + (bevel (* 2 (or (cdr (assq 'toolbar-shadow-thickness (frame-parameters))) + 0))) + (captioned (specifier-instance toolbar-buttons-captioned-p)) + button glyph glyph-list) + (while toolbar + (setq button (car toolbar)) + (cond ((null button) + (setq width (+ width 8))) + ((eq (elt button 0) ':size) + (setq width (+ width (elt button 1)))) + ((and (eq (elt button 0) ':style) + (= (length button) 4) + (eq (elt button 2) ':size)) + (setq width (+ width bevel (elt button 3)))) + (t + (setq glyph-list (elt button 0)) + (if (symbolp glyph-list) + (setq glyph-list (symbol-value glyph-list))) + (if (and captioned (> (length glyph-list) 3)) + (setq glyph (or (nth 3 glyph-list) + (nth 4 glyph-list) + (nth 5 glyph-list))) + (setq glyph (car glyph-list))) + (setq width (+ width bevel (glyph-width glyph))) + (or height (setq height (+ bevel (glyph-height glyph)))))) + (setq toolbar (cdr toolbar))) + (set-specifier top-toolbar-height height floating-toolbar-frame) + (set-frame-width floating-toolbar-frame + (1+ (/ width (font-width (face-font 'default) + floating-toolbar-frame)))))) + +(defun floating-toolbar-set-toolbar-frame-position (x y) + (set-frame-position floating-toolbar-frame x y)) + +(defun floating-toolbar-make-junk-frame () + (let ((window-min-height 1) + (window-min-width 1)) + (make-frame '(minibuffer t initially-unmapped t width 1 height 1)))) + +(defun floating-toolbar-make-toolbar-frame (x y) + (save-excursion + (let ((window-min-height 1) + (window-min-width 1) + (bg-color (or (x-get-resource "backgroundToolBarColor" + "BackgroundToolBarColor" + 'string + 'global + (selected-device) + t) + "grey75")) + (buffer (get-buffer-create " *floating-toolbar-buffer*")) + (frame nil)) + (set-buffer buffer) + (set-buffer-menubar nil) + (if floating-toolbar-help-font + (progn (set-buffer (window-buffer (minibuffer-window))) + (set-buffer-menubar nil))) + (setq frame (make-frame (list + '(initially-unmapped . t) + ;; try to evade frame decorations + (cons 'name (or floating-toolbar-frame-name + "xclock")) + '(border-width . 2) + (cons 'border-color bg-color) + (cons 'top y) + (cons 'left x) + (cons 'popup + (floating-toolbar-make-junk-frame)) + (if floating-toolbar-help-font + '(minibuffer . only) + '(minibuffer . nil)) + '(width . 3) + '(height . 1)))) + (set-specifier text-cursor-visible-p (cons frame nil)) + (if floating-toolbar-help-font + (set-face-font 'default floating-toolbar-help-font frame) + (set-face-font 'default "nil2" frame)) + (set-face-background 'default bg-color frame) + (set-face-background 'modeline bg-color frame) + (set-specifier modeline-shadow-thickness (cons frame 1)) + (set-specifier has-modeline-p (cons frame nil)) + (set-face-background-pixmap 'default "" frame) + (set-window-buffer (frame-selected-window frame) buffer) + (set-specifier top-toolbar-height (cons frame 0)) + (set-specifier left-toolbar-width (cons frame 0)) + (set-specifier right-toolbar-width (cons frame 0)) + (set-specifier bottom-toolbar-height (cons frame 0)) + (set-specifier top-toolbar (cons frame nil)) + (set-specifier left-toolbar (cons frame nil)) + (set-specifier right-toolbar (cons frame nil)) + (set-specifier bottom-toolbar (cons frame nil)) + (set-specifier scrollbar-width (cons frame 0)) + (set-specifier scrollbar-height (cons frame 0)) + frame ))) + +;; first popup should be faster if we go ahead and make the frame now. +(or floating-toolbar-frame + (not (eq (device-type) 'x)) + (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame 0 0))) + +;;; floating-toolbar.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/utils/redo.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/redo.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,187 @@ +;;; redo.el -- Redo/undo system for XEmacs + +;; Copyright (C) 1985, 1986, 1987, 1993-1995 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1997 Kyle E. Jones + +;; Author: Kyle E. Jones, February 1997 +;; Keywords: lisp, extensions + +;; 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 +;; 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. + +;; 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. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; Derived partly from lisp/prim/simple.el in XEmacs. + +;; Emacs' normal undo system allows you to undo an arbitrary +;; number of buffer changes. These undos are recorded as ordinary +;; buffer changes themselves. So when you break the chain of +;; undos by issuing some other command, you can then undo all +;; the undos. The chain of recorded buffer modifications +;; therefore grows without bound, truncated only at garbage +;; collection time. +;; +;; The redo/undo system is different in two ways: +;; 1. The undo/redo command chain is only broken by a buffer +;; modification. You can move around the buffer or switch +;; buffers and still come back and do more undos or redos. +;; 2. The `redo' command rescinds the most recent undo without +;; recording the change as a _new_ buffer change. It +;; completely reverses the effect of the undo, which +;; includes making the chain of buffer modification records +;; shorter by one, to counteract the effect of the undo +;; command making the record list longer by one. +;; +;; Installation: +;; +;; Save this file as redo.el, byte compile it and put the +;; resulting redo.elc file in a directory that is listed in +;; load-path. +;; +;; In your .emacs file, add +;; (require 'redo) +;; and the system will be enabled. + +;;; Code: + +(provide 'redo) + +(defvar redo-version "1.00" + "Version number for the Redo package.") + +(defvar last-buffer-undo-list nil + "The head of buffer-undo-list at the last time an undo or redo was done.") +(make-variable-buffer-local 'last-buffer-undo-list) + +(defun redo (&optional count) + "Redo the the most recent undo. +Prefix arg COUNT means redo the COUNT most recent undos. +If you have modified the buffer since the last redo or undo, +then you cannot redo any undos before then." + (interactive "*p") + (if (eq buffer-undo-list t) + (error "No undo information in this buffer")) + (if (eq last-buffer-undo-list nil) + (error "No undos to redo")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (error "Buffer modified since last undo/redo, cannot redo")) + (and (or (eq buffer-undo-list pending-undo-list) + (eq (cdr buffer-undo-list) pending-undo-list)) + (error "No further undos to redo in this buffer")) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo...")) + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p)) + (old-undo-list buffer-undo-list) + (p (cdr buffer-undo-list)) + (records-between 0)) + ;; count the number of undo records between the head of teh + ;; undo chain and the pointer to the next change. Note that + ;; by `record' we mean clumps of change records, not the + ;; boundary records. The number of records will always be a + ;; multiple of 2, because an undo moves the pending pointer + ;; forward one record and prepend a record to the head of the + ;; chain. Thus the separation always increases by two. WHen + ;; we decrease it we will decrease it by a multiple of 2 + ;; also. + (while p + (cond ((eq p pending-undo-list) + (setq p nil)) + ((null (car p)) + (setq records-between (1+ records-between)) + (setq p (cdr p))) + (t + (setq p (cdr p))))) + ;; we're off by one if pending pointer is nil, because there + ;; was no boundary record in front of it to count. + (and (null pending-undo-list) + (setq records-between (1+ records-between))) + ;; don't allow the user to redo more undos than exist. + ;; only half the records between the list head and the pending + ;; pointer are undos that are a part of this command chain. + (setq count (min (/ records-between 2) count) + p (primitive-undo (1+ count) buffer-undo-list)) + (if (eq p old-undo-list) + nil ;; nothing happened + ;; set buffer-undo-list to the new undo list. if has been + ;; shortened by `count' records. + (setq buffer-undo-list p) + ;; primitive-undo returns a list without a leading undo + ;; boundary. add one. + (undo-boundary) + ;; now move the pending pointer backward in the undo list + ;; to reflect the redo. sure would be nice if this list + ;; were doubly linked, but no... so we have to run down the + ;; list from the head and stop at the right place. + (let ((n (- records-between count))) + (setq p (cdr old-undo-list)) + (while (and p (> n 0)) + (if (null (car p)) + (setq n (1- n))) + (setq p (cdr p))) + (setq pending-undo-list p))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save)) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo!")) + (setq last-buffer-undo-list buffer-undo-list))) + +(defun undo (&optional arg) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "*p") + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo...")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (progn (undo-start) + (undo-more 1))) + (undo-more (or arg 1)) + ;; Don't specify a position in the undo record for the undo command. + ;; Instead, undoing this should move point to where the change is. + ;; + ;;;; The old code for this was mad! It deleted all set-point + ;;;; references to the position from the whole undo list, + ;;;; instead of just the cells from the beginning to the next + ;;;; undo boundary. This does what I think the other code + ;;;; meant to do. + (let ((list buffer-undo-list) + (prev nil)) + (while (and list (not (null (car list)))) + (if (integerp (car list)) + (if prev + (setcdr prev (cdr list)) + ;; impossible now, but maybe not in the future + (setq buffer-undo-list (cdr list)))) + (setq prev list + list (cdr list)))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo!")) + (setq last-buffer-undo-list buffer-undo-list)) + +;;; redo.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc lisp/version.el --- a/lisp/version.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/version.el Mon Aug 13 09:13:56 2007 +0200 @@ -22,10 +22,10 @@ ;;; Code: -(defconst emacs-version "20.0" +(defconst emacs-version "20.1" "Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta1)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/Makefile --- a/lisp/vm/Makefile Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/Makefile Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,13 @@ # what Emacs version to build VM for. # Allowed values are 18 and 19. +# Version 18 of Emacs is UNSUPPORTED. +# In fact all versions of Emacs prior to 19.34 for Emacs and +# prior to 19.14 for XEmacs are unsupported. # -# Currently only vm-isearch-forward depends on this being -# correct. You can use the same VM .elc files under v18 and v19 -# Emacs if you don't care about vm-isearch-forward. +# Currently only vm-isearch-forward depends on the EMACS_VERSION +# setting being correct. You can use the same VM .elc files +# under v18 and v19 Emacs if you don't care about +# vm-isearch-forward. # # Note that .elc files compiled with the v19 byte compiler won't # work under v18 Emacs, but v18 .elcs will work under v19. So @@ -50,7 +54,7 @@ OBJECTS = \ vm-delete.elc vm-digest.elc vm-easymenu.elc vm-edit.elc vm-folder.elc \ vm-license.elc vm-mark.elc vm-menu.elc vm-message.elc \ - vm-minibuf.elc vm-misc.elc vm-mouse.elc \ + vm-mime.elc vm-minibuf.elc vm-misc.elc vm-mouse.elc \ vm-motion.elc vm-page.elc vm-pop.elc vm-reply.elc \ vm-save.elc \ vm-search.elc vm-sort.elc vm-summary.elc vm-startup.elc vm-thread.elc \ @@ -60,7 +64,7 @@ SOURCES = \ vm-delete.el vm-digest.el vm-easymenu.el vm-edit.el vm-folder.el \ vm-license.el vm-mark.el vm-menu.el vm-message.el \ - vm-minibuf.el vm-misc.el vm-mouse.el \ + vm-mime.el vm-minibuf.el vm-misc.el vm-mouse.el \ vm-motion.el vm-page.el vm-pop.el vm-reply.el vm-save.el \ vm-search.el vm-sort.el vm-startup.el vm-summary.el vm-thread.el \ vm-toolbar.el \ @@ -142,6 +146,10 @@ @echo compiling vm-minibuf.el... @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-minibuf.el +vm-mime.elc: vm-mime.el $(CORE) + @echo compiling vm-mime.el... + @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-mime.el + vm-misc.elc: vm-misc.el $(CORE) @echo compiling vm-misc.el... @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-misc.el diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/README --- a/lisp/vm/README Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/README Mon Aug 13 09:13:56 2007 +0200 @@ -5,7 +5,8 @@ system, change them. Note that version 18 of Emacs is no longer supported. VM may - or may not work under v18. + or may not work under v18. The old v18 support code has been left + in place for those hardy souls who want to attempt it anyway. 1) Do one of these: `make'. @@ -16,7 +17,7 @@ 2) Put all the .elc files into a Lisp directory that Emacs knows about. (see load-path). -3) If you're using XEmacs 19.12 and you want toolbar support, +3) If you're using XEmacs 19.14 and you want toolbar support, make a directory called `vm' in the XEmacs `etc' directory. Copy the files in pixmaps directory into the directory you just created. VM will look for the pixmap there by default. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/tapestry.el --- a/lisp/vm/tapestry.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/tapestry.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Tools to configure your GNU Emacs windows -;;; Copyright (C) 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1991, 1993, 1994, 1995, 1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -20,7 +20,12 @@ (provide 'tapestry) -(defvar tapestry-version "1.07") +(defvar tapestry-version "1.08") + +;; Pass state information between the tapestry-set-window-map +;; and tapestry-set-buffer-map stages. UGH. The reason for this +;; is explained in tapestry-set-buffer-map. +(defvar tapestry-windows-changed nil) (defun tapestry (&optional frame-list) "Returns a list containing complete information about the current @@ -69,6 +74,7 @@ coordinates can be found, the window with the greatest overlap of ROOT-WINDOW-EDGES will be used." (let ((sf (tapestry-selected-frame)) + (tapestry-windows-changed nil) frame-list frame-map other-maps other-map) (setq frame-map (nth 0 map) other-maps (nth 1 map)) @@ -195,12 +201,14 @@ (delete-window inside-w))) (t (setq root-window overlap-w)))) (tapestry-apply-window-map map map-width map-height root-window) + (setq tapestry-windows-changed t) root-window ) (if (tapestry-windows-match-map map map-width map-height) (tapestry-first-window) (delete-other-windows) (setq root-window (selected-window)) (tapestry-apply-window-map map map-width map-height root-window) + (setq tapestry-windows-changed t) root-window )))) (defun tapestry-buffer-map () @@ -214,16 +222,50 @@ w-list (cdr w-list))) (nreverse list))) +;; This version of tapestry-set-buffer-map unconditionally set +;; the window buffer. This confused XEmacs 19.14's scroll-up +;; function when scrolling VM presentation buffers. +;; end-of-buffer was never signaled after a scroll. You can +;; duplicate this by creating a buffer that can be displayed +;; fully in the current window and then run +;; +;; (progn +;; (set-window-buffer (selected-window) (current-buffer)) +;; (scroll-up nil)) +;;;;;;;;;;; +;;(defun tapestry-set-buffer-map (buffer-map &optional first-window) +;; (let ((w-list (tapestry-window-list first-window)) wb) +;; (while (and w-list buffer-map) +;; (setq wb (car buffer-map)) +;; (set-window-buffer +;; (car w-list) +;; (if (car wb) +;; (or (get-file-buffer (car wb)) +;; (find-file-noselect (car wb))) +;; (get-buffer-create (nth 1 wb)))) +;; (setq w-list (cdr w-list) +;; buffer-map (cdr buffer-map))))) + (defun tapestry-set-buffer-map (buffer-map &optional first-window) - (let ((w-list (tapestry-window-list first-window)) wb) + (let ((w-list (tapestry-window-list first-window)) + current-wb proposed-wb cell) (while (and w-list buffer-map) - (setq wb (car buffer-map)) - (set-window-buffer - (car w-list) - (if (car wb) - (or (get-file-buffer (car wb)) - (find-file-noselect (car wb))) - (get-buffer-create (nth 1 wb)))) + (setq cell (car buffer-map) + proposed-wb (if (car cell) + (or (get-file-buffer (car cell)) + (find-file-noselect (car cell))) + (get-buffer-create (nth 1 cell))) + current-wb (window-buffer (car w-list))) + ;; Setting the window buffer to the same value it already + ;; has seems to confuse XEmacs' scroll-up function. But + ;; _not_ setting after windows torn down seem to cause + ;; window point to sometimes drift away from point at + ;; redisplay time. The solution (hopefully!) is to track + ;; when windows have been rearranged and unconditionally do + ;; the set-window-buffer, otherwise do it only if the + ;; window buffer and the prosed window buffer differ. + (if (or tapestry-windows-changed (not (eq proposed-wb current-wb))) + (set-window-buffer (car w-list) proposed-wb)) (setq w-list (cdr w-list) buffer-map (cdr buffer-map))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-autoload.el --- a/lisp/vm/vm-autoload.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-autoload.el Mon Aug 13 09:13:56 2007 +0200 @@ -6,7 +6,7 @@ time the current folder is expunged. With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are deleted. A negative argument means the +COUNT - 1 messages are deleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. @@ -18,7 +18,7 @@ (autoload (quote vm-undelete-message) "vm-delete" "Remove the `deleted' attribute from the current message. With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are undeleted. A negative argument means the +COUNT - 1 messages are undeleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. @@ -27,7 +27,13 @@ (autoload (quote vm-kill-subject) "vm-delete" "Delete all messages with the same subject as the current message. Message subjects are compared after ignoring parts matched by -the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix." t nil) +the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix. + +The optional prefix argument ARG specifies the direction to move +if vm-move-after-killing is non-nil. The default direction is +forward. A positive prefix argument means move forward, a +negative arugment means move backward, a zero argument means +don't move at all." t nil) (autoload (quote vm-expunge-folder) "vm-delete" "Expunge messages with the `deleted' attribute. For normal folders this means that the deleted messages are @@ -56,6 +62,28 @@ to be forwarded. See the docs for vm-reorder-message-headers to find out how KEEP-LIST and DISCARD-REGEXP are used." nil nil) +(autoload (quote vm-mime-encapsulate-messages) "vm-digest" "Encapsulate the messages in MESSAGE-LIST as per the MIME spec. +The resulting digest is inserted at point in the current buffer. +Point is not moved. + +MESSAGE-LIST should be a list of message structs (real or virtual). +These are the messages that will be encapsulated. +KEEP-LIST should be a list of regexps matching headers to keep. +DISCARD-REGEXP should be a regexp that matches headers to be discarded. +KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers +to be forwarded. See the docs for vm-reorder-message-headers +to find out how KEEP-LIST and DISCARD-REGEXP are used. + +Returns the multipart boundary parameter (string) that should be used +in the Content-Type header." nil nil) + +(autoload (quote vm-mime-burst-message) "vm-digest" "Burst messages from the digest message M. +M should be a message struct for a real message. +MIME encoding is expected. The message content type +must be either message/* or multipart/digest." nil nil) + +(autoload (quote vm-mime-burst-layout) "vm-digest" nil nil nil) + (autoload (quote vm-rfc934-char-stuff-region) "vm-digest" "Quote RFC 934 message separators between START and END. START and END are buffer positions in the current buffer. Lines beginning with `-' in the region have `- ' prepended to them." nil nil) @@ -126,9 +154,11 @@ (autoload (quote vm-burst-rfc1153-digest) "vm-digest" "Burst an RFC 1153 style digest" t nil) +(autoload (quote vm-burst-mime-digest) "vm-digest" "Burst a MIME digest" t nil) + (autoload (quote vm-guess-digest-type) "vm-digest" "Guess the digest type of the message M. M should be the message struct of a real message. -Returns either \"rfc934\" or \"rfc1153\"." nil nil) +Returns either \"rfc934\", \"rfc1153\" or \"mime\"." nil nil) (autoload (quote vm-easy-menu-define) "vm-easymenu" "Define a menu bar submenu in maps MAPS, according to MENU. The menu keymap is stored in symbol SYMBOL, both as its value @@ -295,8 +325,8 @@ START-POINT should be a cons in vm-message-list or just t. (t means start from the beginning of vm-message-list.) If START-POINT is closer to the head of vm-message-list than -vm-numbering-redo-start-point or is equal to t, then -vm-numbering-redo-start-point is set to match it." nil nil) +vm-summary-redo-start-point or is equal to t, then +vm-summary-redo-start-point is set to match it." nil nil) (autoload (quote vm-mark-for-summary-update) "vm-folder" "Mark message M for a summary update. Also mark M's buffer as needing a display update. Any virtual @@ -316,11 +346,14 @@ (autoload (quote vm-do-needed-mode-line-update) "vm-folder" "Do a modeline update for the current folder buffer. This means setting up all the various vm-ml attribute variables in the folder buffer and copying necessary variables to the -folder buffer's summary buffer, and then forcing Emacs to update -all modelines. - -Also if a virtual folder being updated has no messages, -erase-buffer is called on its buffer." nil nil) +folder buffer's summary and presentation buffers, and then +forcing Emacs to update all modelines. + +If a virtual folder being updated has no messages, then +erase-buffer is called on its buffer. + +If any type of folder is empty, erase-buffer is called +on its presentation buffer, if any." nil nil) (autoload (quote vm-update-summary-and-mode-line) "vm-folder" "Update summary and mode line for all VM folder and summary buffers. Really this updates all the visible status indicators. @@ -385,7 +418,7 @@ This function works by examining the beginning of a folder. If optional arg FILE is present the type of FILE is returned instead. If optional second and third arg START and END are provided, -vm-get-folder-type will examine the the text between those buffer +vm-get-folder-type will examine the text between those buffer positions. START and END default to 1 and (buffer-size) + 1. Returns @@ -514,6 +547,8 @@ (autoload (quote vm-stuff-attributes) "vm-folder" nil nil nil) +(autoload (quote vm-stuff-folder-attributes) "vm-folder" nil nil nil) + (autoload (quote vm-stuff-babyl-attributes) "vm-folder" nil nil nil) (autoload (quote vm-babyl-attributes-string) "vm-folder" nil nil nil) @@ -645,6 +680,10 @@ Interactively TYPE will be read from the minibuffer." t nil) +(autoload (quote vm-garbage-collect-folder) "vm-folder" nil nil nil) + +(autoload (quote vm-garbage-collect-message) "vm-folder" nil nil nil) + (autoload (quote vm-show-copying-restrictions) "vm-license" nil t nil) (autoload (quote vm-show-no-warranty) "vm-license" "Display \"NO WARRANTY\" section of the GNU General Public License." t nil) @@ -663,6 +702,12 @@ N-1 messages. A negative N means unmark the current message and the previous N-1 messages." t nil) +(autoload (quote vm-mark-summary-region) "vm-mark" "Mark all messages with summary lines contained in the region." t nil) + +(autoload (quote vm-unmark-summary-region) "vm-mark" "Remove marks from messages with summary lines contained in the region." t nil) + +(autoload (quote vm-mark-or-unmark-summary-region) "vm-mark" nil nil nil) + (autoload (quote vm-mark-or-unmark-messages-with-selector) "vm-mark" nil nil nil) (autoload (quote vm-mark-matching-messages) "vm-mark" "Mark messages matching some criterion. @@ -720,6 +765,8 @@ (autoload (quote vm-menu-can-undo-p) "vm-menu" nil nil nil) +(autoload (quote vm-menu-can-decode-mime-p) "vm-menu" nil nil nil) + (autoload (quote vm-menu-yank-original) "vm-menu" nil t nil) (autoload (quote vm-menu-can-send-mail-p) "vm-menu" nil nil nil) @@ -742,6 +789,8 @@ (autoload (quote vm-menu-popup-url-browser-menu) "vm-menu" nil t nil) +(autoload (quote vm-menu-popup-mime-dispose-menu) "vm-menu" nil t nil) + (autoload (quote vm-menu-popup-fsfemacs-menu) "vm-menu" nil t nil) (autoload (quote vm-menu-mode-menu) "vm-menu" nil nil nil) @@ -846,6 +895,10 @@ (autoload (quote vm-virtual-summary-of) "vm-message" nil nil t) +(autoload (quote vm-mime-layout-of) "vm-message" nil nil t) + +(autoload (quote vm-mime-encoded-header-flag-of) "vm-message" nil nil t) + (autoload (quote vm-attributes-of) "vm-message" nil nil t) (autoload (quote vm-new-flag) "vm-message" nil nil t) @@ -970,6 +1023,10 @@ (autoload (quote vm-set-virtual-summary-of) "vm-message" nil nil t) +(autoload (quote vm-set-mime-layout-of) "vm-message" nil nil t) + +(autoload (quote vm-set-mime-encoded-header-flag-of) "vm-message" nil nil t) + (autoload (quote vm-set-attributes-of) "vm-message" nil nil t) (autoload (quote vm-set-edited-flag-of) "vm-message" nil nil nil) @@ -1036,6 +1093,280 @@ (autoload (quote vm-virtual-message-p) "vm-message" nil nil nil) +(autoload (quote vm-mime-error) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-type) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-encoding) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-id) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-description) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-disposition) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-header-start) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-body-start) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-body-end) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-parts) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout-cache) "vm-mime" nil nil nil) + +(autoload (quote vm-set-mm-layout-cache) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-layout) "vm-mime" nil nil nil) + +(autoload (quote vm-mm-encoded-header) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-Q-decode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-Q-encode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-Q-decode-string) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-B-decode-string) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-Q-encode-string) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-B-encode-string) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-crlf-to-lf-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-lf-to-crlf-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-charset-decode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-transfer-decode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-base64-decode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-base64-encode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-qp-decode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-qp-encode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-decode-mime-message-headers) "vm-mime" nil nil nil) + +(autoload (quote vm-decode-mime-encoded-words) "vm-mime" nil nil nil) + +(autoload (quote vm-decode-mime-encoded-words-maybe) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-parse-content-header) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-get-header-contents) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-parse-entity) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-parse-entity-safe) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-get-xxx-parameter) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-get-parameter) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-get-disposition-parameter) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-insert-mime-body) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-insert-mime-headers) "vm-mime" nil nil nil) + +(autoload (quote vm-make-presentation-copy) "vm-mime" nil nil nil) + +(autoload (quote vm-determine-proper-charset) "vm-mime" nil nil nil) + +(autoload (quote vm-determine-proper-content-transfer-encoding) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-types-match) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-can-display-internal) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-can-convert) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-convert-undisplayable-layout) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-should-display-button) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-should-display-internal) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-find-external-viewer) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-delete-button-maybe) "vm-mime" nil nil nil) + +(autoload (quote vm-decode-mime-message) "vm-mime" "Decode the MIME objects in the current message. + +The first time this command is run on a message, decoding is done. +The second time, buttons for all the objects are displayed instead. +The third time, the raw, undecoded data is displayed. + +If decoding, the decoded objects might be displayed immediately, or +buttons might be displayed that you need to activate to view the +object. See the documentation for the variables + + vm-auto-displayed-mime-content-types + vm-mime-internal-content-types + vm-mime-external-content-types-alist + +to see how to control whether you see buttons or objects. + +If the variable vm-mime-display-function is set, then its value +is called as a function with no arguments, and none of the +actions mentioned in the preceding paragraphs are done. At the +time of the call, the current buffer will be the presentation +buffer for the folder and a copy of the current message will be +in the buffer. The function is expected to make the message +`MIME presentable' to the user in whatever manner it sees fit." t nil) + +(autoload (quote vm-decode-mime-layout) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-text) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-text/html) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-text/plain) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-text/enriched) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-external-generic) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-application/octet-stream) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-image) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-audio) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-video) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-message) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-multipart) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-multipart/mixed) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-multipart/alternative) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-multipart/parallel) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-multipart/digest) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-message/rfc822) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-message/partial) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-image-xxxx) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-image/gif) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-image/jpeg) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-image/png) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-image/tiff) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-internal-audio/basic) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-display-button-xxxx) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-run-display-function-at-point) "vm-mime" nil t nil) + +(autoload (quote vm-mime-insert-button) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-send-body-to-file) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-pipe-body-to-command) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-pipe-body-to-command-discard-output) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-scrub-description) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-layout-description) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-layout-contains-type) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-plain-message-p) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-text-type-p) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-charset-internally-displayable-p) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-find-message/partials) "vm-mime" nil nil nil) + +(autoload (quote vm-message-at-point) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-make-multipart-boundary) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-attach-file) "vm-mime" "Attach a file to a VM composition buffer to be sent along with the message. +The file is not inserted into the buffer and MIME encoded until +you execute vm-mail-send or vm-mail-send-and-exit. A visible tag +indicating the existence of the attachment is placed in the +composition buffer. You can move the attachment around or remove +it entirely with normal text editing commands. If you remove the +attachment tag, the attachment will not be sent. + +First argument, FILE, is the name of the file to attach. Second +argument, TYPE, is the MIME Content-Type of the file. Optional +third argument CHARSET is the character set of the attached +document. This argument is only used for text types, and it +is ignored for other types. + +When called interactively all arguments are read from the +minibuffer. + +This command is for attaching files that do not have a MIME +header section at the top. For files with MIME headers, you +should use vm-mime-attach-mime-file to attach such a file. VM +will extract the content type information from the headers in +this case and not prompt you for it in the minibuffer." t nil) + +(autoload (quote vm-mime-attach-mime-file) "vm-mime" "Attach a MIME encoded file to a VM composition buffer to be sent +along with the message. + +The file is not inserted into the buffer until you execute +vm-mail-send or vm-mail-send-and-exit. A visible tag indicating +the existence of the attachment is placed in the composition +buffer. You can move the attachment around or remove it entirely +with normal text editing commands. If you remove the attachment +tag, the attachment will not be sent. + +The sole argument, FILE, is the name of the file to attach. +When called interactively the FILE argument is read from the +minibuffer. + +This command is for attaching files that have a MIME +header section at the top. For files without MIME headers, you +should use vm-mime-attach-file to attach such a file. VM +will interactively query you for the file type information." t nil) + +(autoload (quote vm-mime-attach-object) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-default-type-from-filename) "vm-mime" nil nil nil) + +(autoload (quote vm-remove-mail-mode-header-separator) "vm-mime" nil nil nil) + +(autoload (quote vm-add-mail-mode-header-separator) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-transfer-encode-region) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-transfer-encode-layout) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-encode-composition) "vm-mime" "MIME encode the current buffer. +Attachment tags added to the buffer with vm-mime-attach-file are expanded +and the approriate content-type and boundary markup information is added." t nil) + +(autoload (quote vm-mime-fragment-composition) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-preview-composition) "vm-mime" "Show how the current composition buffer might be displayed +in a MIME-aware mail reader. VM copies and encodes the current +mail composition buffer and displays it as a mail folder. +Type `q' to quit this temp folder and return to composing your +message." t nil) + +(autoload (quote vm-mime-composite-type-p) "vm-mime" nil nil nil) + +(autoload (quote vm-mime-map-atomic-layouts) "vm-mime" nil nil nil) + (autoload (quote vm-minibuffer-complete-word) "vm-minibuf" nil t nil) (autoload (quote vm-minibuffer-complete-word-and-exit) "vm-minibuf" nil t nil) @@ -1111,6 +1442,8 @@ (autoload (quote vm-check-for-killed-summary) "vm-misc" nil nil nil) +(autoload (quote vm-check-for-killed-presentation) "vm-misc" nil nil nil) + (autoload (quote vm-check-for-killed-folder) "vm-misc" nil nil nil) (autoload (quote vm-error-if-folder-read-only) "vm-misc" nil nil t) @@ -1139,6 +1472,12 @@ (autoload (quote vm-delete) "vm-misc" nil nil nil) +(autoload (quote vm-delete-directory-file-names) "vm-misc" nil nil nil) + +(autoload (quote vm-delete-backup-file-names) "vm-misc" nil nil nil) + +(autoload (quote vm-delete-auto-save-file-names) "vm-misc" nil nil nil) + (autoload (quote vm-delete-duplicates) "vm-misc" "Delete duplicate equivalent strings from the list. If ALL is t, then if there is more than one occurrence of a string in the list, then all occurrences of it are removed instead of just the subsequent ones. @@ -1158,6 +1497,8 @@ (autoload (quote vm-xemacs-p) "vm-misc" nil nil nil) +(autoload (quote vm-xemacs-mule-p) "vm-misc" nil nil nil) + (autoload (quote vm-fsfemacs-19-p) "vm-misc" nil nil nil) (autoload (quote vm-multiple-frames-possible-p) "vm-misc" nil nil nil) @@ -1192,6 +1533,20 @@ (autoload (quote vm-buffer-string-no-properties) "vm-misc" nil nil nil) +(autoload (quote vm-insert-region-from-buffer) "vm-misc" nil nil nil) + +(autoload (quote vm-copy-extent) "vm-misc" nil nil nil) + +(autoload (quote vm-make-tempfile-name) "vm-misc" nil nil nil) + +(autoload (quote vm-insert-char) "vm-misc" nil nil nil) + +(autoload (quote vm-xemacs-compatible-insert-char) "vm-misc" nil nil nil) + +(autoload (quote vm-symbol-lists-intersect-p) "vm-misc" nil nil nil) + +(autoload (quote vm-set-buffer-variable) "vm-misc" nil nil nil) + (autoload (quote vm-mouse-fsfemacs-mouse-p) "vm-mouse" nil nil nil) (autoload (quote vm-mouse-xemacs-mouse-p) "vm-mouse" nil nil nil) @@ -1202,7 +1557,7 @@ (autoload (quote vm-mouse-button-3) "vm-mouse" nil t nil) -(autoload (quote vm-mouse-3-help) "vm-mouse" "Use mouse button 3 to see a menu of options." nil nil) +(autoload (quote vm-mouse-3-help) "vm-mouse" nil nil nil) (autoload (quote vm-mouse-get-mouse-track-string) "vm-mouse" nil nil nil) @@ -1224,6 +1579,8 @@ (autoload (quote vm-run-command) "vm-mouse" nil nil nil) +(autoload (quote vm-run-command-on-region) "vm-mouse" nil nil nil) + (autoload (quote vm-mouse-read-file-name) "vm-mouse" "Like read-file-name, except uses a mouse driven interface. HISTORY argument is ignored." nil nil) @@ -1320,6 +1677,14 @@ (autoload (quote vm-url-help) "vm-page" nil nil nil) +(autoload (quote vm-energize-urls-in-message-region) "vm-page" nil nil nil) + +(autoload (quote vm-highlight-headers-maybe) "vm-page" nil nil nil) + +(autoload (quote vm-energize-headers-and-xfaces) "vm-page" nil nil nil) + +(autoload (quote vm-narrow-for-preview) "vm-page" nil nil nil) + (autoload (quote vm-preview-current-message) "vm-page" nil nil nil) (autoload (quote vm-show-current-message) "vm-page" nil nil nil) @@ -1397,6 +1762,8 @@ (autoload (quote vm-mail-send) "vm-reply" "Just like mail-send except that VM flags the appropriate message(s) as replied to, forwarded, etc, if appropriate." t nil) +(autoload (quote vm-mail-mode-get-header-contents) "vm-reply" nil nil nil) + (autoload (quote vm-rename-current-mail-buffer) "vm-reply" nil nil nil) (autoload (quote vm-mail-mark-replied) "vm-reply" nil nil nil) @@ -1471,6 +1838,8 @@ (autoload (quote vm-send-rfc1153-digest) "vm-reply" "Like vm-send-digest but always sends an RFC 1153 digest." t nil) +(autoload (quote vm-send-mime-digest) "vm-reply" "Like vm-send-digest but always sends an MIME (multipart/digest) digest." t nil) + (autoload (quote vm-continue-composing-message) "vm-reply" "Find and select the most recently used mail composition buffer. If the selected buffer is already a Mail mode buffer then it is buried before beginning the search. Non Mail mode buffers and @@ -1478,6 +1847,8 @@ Mail mode buffers are not skipped. If no suitable buffer is found, the current buffer remains selected." t nil) +(autoload (quote vm-mail-to-mailto-url) "vm-reply" nil nil nil) + (autoload (quote vm-mail-internal) "vm-reply" nil nil nil) (autoload (quote vm-reply-other-frame) "vm-reply" "Like vm-reply, but run in a newly created frame." t nil) @@ -1502,6 +1873,8 @@ (autoload (quote vm-send-rfc1153-digest-other-frame) "vm-reply" "Like vm-send-rfc1153-digest, but run in a newly created frame." t nil) +(autoload (quote vm-send-mime-digest-other-frame) "vm-reply" "Like vm-send-mime-digest, but run in a newly created frame." t nil) + (autoload (quote vm-match-data) "vm-save" nil nil nil) (autoload (quote vm-auto-select-folder) "vm-save" nil nil nil) @@ -1695,7 +2068,7 @@ (autoload (quote vm-mode) "vm-startup" "Major mode for reading mail. -This is VM 5.96 (beta). +This is VM 6.13. Commands: h - summarize folder contents @@ -1735,7 +2108,7 @@ @ - digestify and mail entire folder contents (the folder is not modified) * - burst a digest into individual messages, and append and assimilate these - message into the current folder. + messages into the current folder. G - sort messages by various keys @@ -1764,14 +2137,16 @@ M U - unmark the current message M m - mark all messages M u - unmark all messages - M C - mark messages matches by a virtual folder selector - M c - unmark messages matches by a virtual folder selector + M C - mark messages matched by a virtual folder selector + M c - unmark messages matched by a virtual folder selector M T - mark thread tree rooted at the current message M t - unmark thread tree rooted at the current message M S - mark messages with the same subject as the current message M s - unmark messages with the same subject as the current message M A - mark messages with the same author as the current message M a - unmark messages with the same author as the current message + M R - mark messages within the point/mark region in the summary + M r - unmark messages within the point/mark region in the summary M ? - partial help for mark commands @@ -1818,17 +2193,21 @@ vm-arrived-message-hook vm-arrived-messages-hook vm-auto-center-summary + vm-auto-decode-mime-messages + vm-auto-displayed-mime-content-types vm-auto-folder-alist vm-auto-folder-case-fold-search vm-auto-get-new-mail vm-auto-next-message vm-berkeley-mail-compatibility + vm-burst-digest-messages-inherit-labels vm-check-folder-types - vm-convert-folder-types vm-circular-folders vm-confirm-new-folders vm-confirm-quit + vm-convert-folder-types vm-crash-box + vm-crash-box-suffix vm-default-folder-type vm-delete-after-archiving vm-delete-after-bursting @@ -1839,6 +2218,7 @@ vm-digest-preamble-format vm-digest-send-type vm-display-buffer-hook + vm-display-using-mime vm-edit-message-hook vm-folder-directory vm-folder-read-only @@ -1848,8 +2228,11 @@ vm-forwarding-digest-type vm-forwarding-subject-format vm-frame-parameter-alist + vm-frame-per-completion vm-frame-per-composition + vm-frame-per-edit vm-frame-per-folder + vm-frame-per-summary vm-highlighted-header-face vm-highlighted-header-regexp vm-honor-page-delimiters @@ -1858,32 +2241,52 @@ vm-included-text-discard-header-regexp vm-included-text-headers vm-included-text-prefix - vm-inhibit-startup-message vm-invisible-header-regexp vm-jump-to-new-messages vm-jump-to-unread-messages + vm-keep-crash-boxes vm-keep-sent-messages - vm-keep-crash-boxes vm-mail-header-from vm-mail-mode-hook + vm-make-crash-box-name + vm-make-spool-file-name + vm-mime-8bit-composition-charset + vm-mime-8bit-text-transfer-encoding + vm-mime-alternative-select-method + vm-mime-attachment-auto-type-alist + vm-mime-attachment-save-directory + vm-mime-avoid-folding-content-type + vm-mime-base64-decoder-program + vm-mime-base64-decoder-switches + vm-mime-base64-encoder-program + vm-mime-base64-encoder-switches + vm-mime-button-face + vm-mime-digest-discard-header-regexp + vm-mime-digest-headers + vm-mime-display-function + vm-mime-external-content-types-alist + vm-mime-internal-content-types + vm-mime-max-message-size vm-mode-hook vm-mosaic-program vm-move-after-deleting + vm-move-after-killing vm-move-after-undeleting vm-move-messages-physically + vm-mutable-frames vm-mutable-windows - vm-mutable-frames vm-netscape-program - vm-options-file vm-pop-md5-program + vm-popup-menu-on-mouse-3 + vm-preferences-file vm-preview-lines vm-preview-read-messages vm-primary-inbox vm-quit-hook vm-recognize-pop-maildrops vm-reply-hook + vm-reply-ignored-addresses vm-reply-ignored-reply-tos - vm-reply-ignored-addresses vm-reply-subject-prefix vm-resend-bounced-discard-header-regexp vm-resend-bounced-headers @@ -1901,9 +2304,11 @@ vm-select-new-message-hook vm-select-unread-message-hook vm-send-digest-hook + vm-send-using-mime vm-skip-deleted-messages vm-skip-read-messages vm-spool-files + vm-spool-file-suffixes vm-startup-with-summary vm-strip-reply-headers vm-summary-arrow @@ -1912,14 +2317,16 @@ vm-summary-mode-hook vm-summary-redo-hook vm-summary-show-threads - vm-summary-subject-no-newlines vm-summary-thread-indent-level + vm-temp-file-directory + vm-tale-is-an-idiot vm-trust-From_-with-Content-Length vm-undisplay-buffer-hook vm-unforwarded-header-regexp vm-url-browser vm-url-search-limit vm-use-menus + vm-use-toolbar vm-virtual-folder-alist vm-virtual-mirror vm-visible-headers @@ -1971,6 +2378,8 @@ (autoload (quote vm-load-init-file) "vm-startup" nil t nil) +(autoload (quote vm-check-emacs-version) "vm-startup" nil nil nil) + (autoload (quote vm-session-initialization) "vm-startup" nil nil nil) (autoload (quote vm-summary-mode-internal) "vm-summary" nil nil nil) @@ -2109,6 +2518,10 @@ (autoload (quote vm-toolbar-can-recover-p) "vm-toolbar" nil nil nil) +(autoload (quote vm-toolbar-can-decode-mime-p) "vm-toolbar" nil nil nil) + +(autoload (quote vm-toolbar-can-quit-p) "vm-toolbar" nil nil nil) + (autoload (quote vm-toolbar-update-toolbar) "vm-toolbar" nil nil nil) (autoload (quote vm-toolbar-install-toolbar) "vm-toolbar" nil nil nil) @@ -2243,12 +2656,6 @@ (autoload (quote vm-virtual-help) "vm-virtual" nil t nil) -(autoload (quote vm-delete-directory-file-names) "vm-virtual" nil nil nil) - -(autoload (quote vm-delete-backup-file-names) "vm-virtual" nil nil nil) - -(autoload (quote vm-delete-auto-save-file-names) "vm-virtual" nil nil nil) - (autoload (quote vm-vs-or) "vm-virtual" nil nil nil) (autoload (quote vm-vs-and) "vm-virtual" nil nil nil) @@ -2380,10 +2787,18 @@ (autoload (quote vm-set-hooks-for-frame-deletion) "vm-window" nil nil nil) +(autoload (quote vm-created-this-frame-p) "vm-window" nil nil nil) + (autoload (quote vm-delete-buffer-frame) "vm-window" nil nil nil) +(autoload (quote vm-register-frame) "vm-window" nil nil nil) + (autoload (quote vm-goto-new-frame) "vm-window" nil nil nil) +(autoload (quote vm-goto-new-summary-frame-maybe) "vm-window" nil nil nil) + +(autoload (quote vm-goto-new-folder-frame-maybe) "vm-window" nil nil nil) + (autoload (quote vm-warp-mouse-to-frame-maybe) "vm-window" nil nil nil) (autoload (quote vm-iconify-frame-xxx) "vm-window" nil nil nil) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-delete.el --- a/lisp/vm/vm-delete.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-delete.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Delete and expunge commands for VM. -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -24,7 +24,7 @@ time the current folder is expunged. With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are deleted. A negative argument means the +COUNT - 1 messages are deleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. @@ -71,7 +71,7 @@ "Remove the `deleted' attribute from the current message. With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are undeleted. A negative argument means the +COUNT - 1 messages are undeleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. @@ -107,11 +107,17 @@ (eq vm-move-after-undeleting t)))) (vm-next-message count t executing-kbd-macro))))) -(defun vm-kill-subject () +(defun vm-kill-subject (&optional arg) "Delete all messages with the same subject as the current message. Message subjects are compared after ignoring parts matched by -the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix." - (interactive) +the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix. + +The optional prefix argument ARG specifies the direction to move +if vm-move-after-killing is non-nil. The default direction is +forward. A positive prefix argument means move forward, a +negative arugment means move backward, a zero argument means +don't move at all." + (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) @@ -133,7 +139,16 @@ (message "No messages deleted.") (message "%d message%s deleted" n (if (= n 1) "" "s"))))) (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject)) - (vm-update-summary-and-mode-line)) + (vm-update-summary-and-mode-line) + (cond ((or (not (numberp arg)) (> arg 0)) + (setq arg 1)) + ((< arg 0) + (setq arg -1)) + (t (setq arg 0))) + (if vm-move-after-killing + (let ((vm-circular-folders (and vm-circular-folders + (eq vm-move-after-deleting t)))) + (vm-next-message arg t executing-kbd-macro)))) (defun vm-expunge-folder (&optional shaddap) "Expunge messages with the `deleted' attribute. @@ -273,11 +288,13 @@ (lambda (buffer) (set-buffer (symbol-name buffer)) (if (null vm-system-state) - (if (null vm-message-pointer) - ;; folder is now empty - (progn (setq vm-folder-type nil) - (vm-update-summary-and-mode-line)) - (vm-preview-current-message)) + (progn + (vm-garbage-collect-message) + (if (null vm-message-pointer) + ;; folder is now empty + (progn (setq vm-folder-type nil) + (vm-update-summary-and-mode-line)) + (vm-preview-current-message))) (vm-update-summary-and-mode-line)) (if (not (eq major-mode 'vm-virtual-mode)) (setq vm-message-order-changed diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-digest.el --- a/lisp/vm/vm-digest.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-digest.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Message encapsulation -;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -54,6 +54,149 @@ (goto-char (point-max)) (insert "------- end of forwarded message -------\n")))) +(defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp) + "Encapsulate the messages in MESSAGE-LIST as per the MIME spec. +The resulting digest is inserted at point in the current buffer. +Point is not moved. + +MESSAGE-LIST should be a list of message structs (real or virtual). +These are the messages that will be encapsulated. +KEEP-LIST should be a list of regexps matching headers to keep. +DISCARD-REGEXP should be a regexp that matches headers to be discarded. +KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers +to be forwarded. See the docs for vm-reorder-message-headers +to find out how KEEP-LIST and DISCARD-REGEXP are used. + +Returns the multipart boundary parameter (string) that should be used +in the Content-Type header." + (if message-list + (let ((target-buffer (current-buffer)) + (boundary-positions nil) + (mlist message-list) + (mime-keep-list (append keep-list vm-mime-header-list)) + boundary source-buffer m start n beg) + (save-restriction + ;; narrow to a zero length region to avoid interacting + ;; with anything that might have already been inserted + ;; into the buffer. + (narrow-to-region (point) (point)) + (setq start (point)) + (while mlist + (setq boundary-positions (cons (point-marker) boundary-positions)) + (setq m (vm-real-message-of (car mlist)) + source-buffer (vm-buffer-of m)) + (setq beg (point)) + (vm-insert-region-from-buffer source-buffer (vm-headers-of m) + (vm-text-end-of m)) + (goto-char beg) + (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") + (vm-reorder-message-headers + nil (if (vm-mime-plain-message-p m) + keep-list + mime-keep-list) + discard-regexp) + (goto-char (point-max)) + (setq mlist (cdr mlist))) + (goto-char start) + (setq boundary (vm-mime-make-multipart-boundary)) + (while (re-search-forward (concat "^--" + (regexp-quote boundary) + "\\(--\\)?$") + nil t) + (setq boundary (vm-mime-make-multipart-boundary)) + (goto-char start)) + (goto-char (point-max)) + (insert "\n--" boundary "--\n") + (while boundary-positions + (goto-char (car boundary-positions)) + (insert "\n--" boundary "\n\n") + (setq boundary-positions (cdr boundary-positions))) + (goto-char start) + (setq n (length message-list)) + (insert (format "This is a %s%sMIME encapsulation.\n" + (if (cdr message-list) + "digest, " + "forwarded message, ") + (if (cdr message-list) + (format "%d messages, " n) + ""))) + (goto-char start)) + boundary ))) + +(defun vm-mime-burst-message (m) + "Burst messages from the digest message M. +M should be a message struct for a real message. +MIME encoding is expected. The message content type +must be either message/* or multipart/digest." + (let ((ident-header nil) + (layout (vm-mm-layout m))) + (if vm-digest-identifier-header-format + (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m))) + (vm-mime-burst-layout layout ident-header))) + +(defun vm-mime-burst-layout (layout ident-header) + (let ((work-buffer nil) + (folder-buffer (current-buffer)) + start part-list + (folder-type vm-folder-type)) + (unwind-protect + (vm-save-restriction + (save-excursion + (widen) + (setq work-buffer (generate-new-buffer "*vm-work*")) + (buffer-disable-undo work-buffer) + (set-buffer work-buffer) + (cond ((not (vectorp layout)) + (error "Not a MIME message")) + ((vm-mime-types-match "message" + (car (vm-mm-layout-type layout))) + (insert (vm-leading-message-separator folder-type)) + (and ident-header (insert ident-header)) + (setq start (point)) + (vm-mime-insert-mime-body layout) + (vm-munge-message-separators folder-type start (point)) + (insert (vm-trailing-message-separator folder-type))) + ((vm-mime-types-match "multipart/digest" + (car (vm-mm-layout-type layout))) + (setq part-list (vm-mm-layout-parts layout)) + (while part-list + ;; Maybe we should verify that each part is + ;; of type message/rfc822 in here. But it + ;; seems more useful to just copy whatever + ;; the contents are and let teh user see the + ;; goop, whatever type it really is. + (insert (vm-leading-message-separator folder-type)) + (and ident-header (insert ident-header)) + (setq start (point)) + (vm-mime-insert-mime-body (car part-list)) + (vm-munge-message-separators folder-type start (point)) + (insert (vm-trailing-message-separator folder-type)) + (setq part-list (cdr part-list)))) + (t (error + "MIME type is not multipart/digest or message/rfc822"))) + ;; do header conversions. + (let ((vm-folder-type folder-type)) + (goto-char (point-min)) + (while (vm-find-leading-message-separator) + (vm-skip-past-leading-message-separator) + (vm-convert-folder-type-headers folder-type folder-type) + (vm-find-trailing-message-separator) + (vm-skip-past-trailing-message-separator))) + ;; now insert the messages into the folder buffer + (cond ((not (zerop (buffer-size))) + (set-buffer folder-buffer) + (let ((old-buffer-modified-p (buffer-modified-p)) + (buffer-read-only nil) + (inhibit-quit t)) + (goto-char (point-max)) + (insert-buffer-substring work-buffer) + (set-buffer-modified-p old-buffer-modified-p) + ;; return non-nil so caller knows we found some messages + t )) + ;; return nil so the caller knows we didn't find anything + (t nil)))) + (and work-buffer (kill-buffer work-buffer))))) + (defun vm-rfc934-char-stuff-region (start end) "Quote RFC 934 message separators between START and END. START and END are buffer positions in the current buffer. @@ -92,6 +235,7 @@ to find out how KEEP-LIST and DISCARD-REGEXP are used." (if message-list (let ((target-buffer (current-buffer)) + (mime-keep-list (append keep-list vm-mime-header-list)) (mlist message-list) source-buffer m start n) (save-restriction @@ -116,7 +260,11 @@ (goto-char beg) (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers nil keep-list discard-regexp) + (vm-reorder-message-headers + nil (if (vm-mime-plain-message-p m) + keep-list + mime-keep-list) + discard-regexp) (vm-rfc934-char-stuff-region beg (point-max)))))) (goto-char (point-max)) (insert "---------------") @@ -175,6 +323,7 @@ to find out how KEEP-LIST and DISCARD-REGEXP are used." (if message-list (let ((target-buffer (current-buffer)) + (mime-keep-list (append keep-list vm-mime-header-list)) (mlist message-list) source-buffer m start) (save-restriction @@ -199,7 +348,11 @@ (goto-char beg) (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers nil keep-list discard-regexp) + (vm-reorder-message-headers + nil (if (vm-mime-plain-message-p m) + keep-list + mime-keep-list) + discard-regexp) (vm-rfc1153-char-stuff-region beg (point-max)))))) (goto-char (point-max)) (insert "\n---------------") @@ -228,12 +381,13 @@ separator-regexp "^------------------------------\n") (setq prologue-separator-regexp "^-[^ ].*\n" separator-regexp "^-[^ ].*\n")) - (save-excursion - (vm-save-restriction + (vm-save-restriction + (save-excursion (widen) (unwind-protect (catch 'done (setq work-buffer (generate-new-buffer "*vm-work*")) + (buffer-disable-undo work-buffer) (set-buffer work-buffer) (insert-buffer-substring (vm-buffer-of m) (vm-text-of m) @@ -367,7 +521,9 @@ (error "Couldn't guess digest type.")))) (vm-unsaved-message "Bursting %s digest..." digest-type) (cond - ((cond ((equal digest-type "rfc934") + ((cond ((equal digest-type "mime") + (vm-mime-burst-message m)) + ((equal digest-type "rfc934") (vm-rfc934-burst-message m)) ((equal digest-type "rfc1153") (vm-rfc1153-burst-message m)) @@ -381,8 +537,10 @@ ;; buffer. switch back. (save-excursion (set-buffer start-buffer) - (vm-delete-message 1))) - (vm-assimilate-new-messages t) + ;; don't move message pointer when deleting the message + (let ((vm-move-after-deleting nil)) + (vm-delete-message 1)))) + (vm-assimilate-new-messages t nil (vm-labels-of (car mlist))) ;; do this now so if we error later in another iteration ;; of the loop the summary and mode line will be correct. (vm-update-summary-and-mode-line))) @@ -392,6 +550,7 @@ ;; themselves. (setq totals-blurb (vm-emit-totals-blurb)) (vm-display nil nil '(vm-burst-digest + vm-burst-mime-digest vm-burst-rfc934-digest vm-burst-rfc1153-digest) (list this-command)) @@ -410,16 +569,29 @@ (interactive) (vm-burst-digest "rfc1153")) +(defun vm-burst-mime-digest () + "Burst a MIME digest" + (interactive) + (vm-burst-digest "mime")) + (defun vm-guess-digest-type (m) "Guess the digest type of the message M. M should be the message struct of a real message. -Returns either \"rfc934\" or \"rfc1153\"." - (save-excursion - (set-buffer (vm-buffer-of m)) +Returns either \"rfc934\", \"rfc1153\" or \"mime\"." + (catch 'return-value + (save-excursion + (set-buffer (vm-buffer-of m)) + (let ((layout (vm-mm-layout m))) + (if (and (vectorp layout) + (or (vm-mime-types-match "multipart/digest" + (car (vm-mm-layout-type layout))) + (vm-mime-types-match "message/rfc822" + (car (vm-mm-layout-type layout))))) + (throw 'return-value "mime")))) (save-excursion (save-restriction (widen) (goto-char (vm-text-of m)) - (if (search-forward "\n----------------------------------------------------------------------\n" nil t) - "rfc1153" - "rfc934"))))) + (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t) + "rfc1153") + (t "rfc934")))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-edit.el --- a/lisp/vm/vm-edit.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-edit.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Editing VM messages -;;; Copyright (C) 1990, 1991, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1990, 1991, 1993, 1994, 1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -33,6 +33,7 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (if (and (vm-virtual-message-p (car vm-message-pointer)) @@ -44,7 +45,10 @@ (vm-set-edited-flag-of (car vm-message-pointer) nil) (vm-update-summary-and-mode-line))) (let ((mp vm-message-pointer) - (offset (- (point) (vm-headers-of (car vm-message-pointer)))) + (offset (save-excursion + (if vm-presentation-buffer + (set-buffer vm-presentation-buffer)) + (- (point) (vm-headers-of (car vm-message-pointer))))) (edit-buf (vm-edit-buffer-of (car vm-message-pointer))) (folder-buffer (current-buffer))) (if (not (and edit-buf (buffer-name edit-buf))) @@ -124,6 +128,7 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (let ((mlist (vm-select-marked-or-prefixed-messages count)) m) (while mlist @@ -134,6 +139,9 @@ (vm-set-vheaders-of m nil) (vm-set-vheaders-regexp-of m nil) (vm-set-text-of m nil) + (vm-set-mime-layout-of m nil) + (if (and vm-presentation-buffer (eq (car vm-message-pointer) m)) + (save-excursion (vm-preview-current-message))) (if vm-thread-obarray (vm-build-threads (list m))) (if vm-summary-show-threads @@ -142,6 +150,9 @@ (save-excursion (while v-list (set-buffer (vm-buffer-of (car v-list))) + (if (and vm-presentation-buffer + (eq (car vm-message-pointer) (car v-list))) + (save-excursion (vm-preview-current-message))) (if vm-thread-obarray (vm-build-threads (list (car v-list)))) (if vm-summary-show-threads diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-folder.el --- a/lisp/vm/vm-folder.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-folder.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; VM folder related functions -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995, 1996 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -59,17 +59,18 @@ vm-numbering-redo-start-point or is equal to t, then vm-numbering-redo-start-point is set to match it." (intern (buffer-name) vm-buffers-needing-display-update) - (if (and (consp start-point) (consp vm-numbering-redo-start-point) - (not (eq vm-numbering-redo-start-point t))) - (let ((mp vm-message-list)) - (while (and mp (not (or (eq mp start-point) - (eq mp vm-numbering-redo-start-point)))) - (setq mp (cdr mp))) - (if (null mp) - (error "Something is wrong in vm-set-numbering-redo-start-point")) - (if (eq mp start-point) - (setq vm-numbering-redo-start-point start-point))) - (setq vm-numbering-redo-start-point start-point))) + (if (eq vm-numbering-redo-start-point t) + nil + (if (and (consp start-point) (consp vm-numbering-redo-start-point)) + (let ((mp vm-message-list)) + (while (and mp (not (or (eq mp start-point) + (eq mp vm-numbering-redo-start-point)))) + (setq mp (cdr mp))) + (if (null mp) + (error "Something is wrong in vm-set-numbering-redo-start-point")) + (if (eq mp start-point) + (setq vm-numbering-redo-start-point start-point))) + (setq vm-numbering-redo-start-point start-point)))) (defun vm-set-numbering-redo-end-point (end-point) "Set vm-numbering-redo-end-point to END-POINT if appropriate. @@ -122,20 +123,21 @@ START-POINT should be a cons in vm-message-list or just t. (t means start from the beginning of vm-message-list.) If START-POINT is closer to the head of vm-message-list than -vm-numbering-redo-start-point or is equal to t, then -vm-numbering-redo-start-point is set to match it." +vm-summary-redo-start-point or is equal to t, then +vm-summary-redo-start-point is set to match it." (intern (buffer-name) vm-buffers-needing-display-update) - (if (and (consp start-point) (consp vm-summary-redo-start-point) - (not (eq vm-summary-redo-start-point t))) - (let ((mp vm-message-list)) - (while (and mp (not (or (eq mp start-point) - (eq mp vm-summary-redo-start-point)))) - (setq mp (cdr mp))) - (if (null mp) - (error "Something is wrong in vm-set-summary-redo-start-point")) - (if (eq mp start-point) - (setq vm-summary-redo-start-point start-point))) - (setq vm-summary-redo-start-point start-point))) + (if (eq vm-summary-redo-start-point t) + nil + (if (and (consp start-point) (consp vm-summary-redo-start-point)) + (let ((mp vm-message-list)) + (while (and mp (not (or (eq mp start-point) + (eq mp vm-summary-redo-start-point)))) + (setq mp (cdr mp))) + (if (null mp) + (error "Something is wrong in vm-set-summary-redo-start-point")) + (if (eq mp start-point) + (setq vm-summary-redo-start-point start-point))) + (setq vm-summary-redo-start-point start-point)))) (defun vm-mark-for-summary-update (m &optional dont-kill-cache) "Mark message M for a summary update. @@ -235,22 +237,34 @@ "Do a modeline update for the current folder buffer. This means setting up all the various vm-ml attribute variables in the folder buffer and copying necessary variables to the -folder buffer's summary buffer, and then forcing Emacs to update -all modelines. +folder buffer's summary and presentation buffers, and then +forcing Emacs to update all modelines. -Also if a virtual folder being updated has no messages, -erase-buffer is called on its buffer." +If a virtual folder being updated has no messages, then +erase-buffer is called on its buffer. + +If any type of folder is empty, erase-buffer is called +on its presentation buffer, if any." ;; XXX This last bit should probably should be moved to ;; XXX vm-expunge-folder. (if (null vm-message-pointer) - ;; erase the leftover message if the folder is really empty. - (if (eq major-mode 'vm-virtual-mode) - (let ((buffer-read-only nil) - (omodified (buffer-modified-p))) - (unwind-protect - (erase-buffer) - (set-buffer-modified-p omodified)))) + (progn + ;; erase the leftover message if the folder is really empty. + (if (eq major-mode 'vm-virtual-mode) + (let ((buffer-read-only nil) + (omodified (buffer-modified-p))) + (unwind-protect + (erase-buffer) + (set-buffer-modified-p omodified)))) + (if vm-presentation-buffer + (let ((omodified (buffer-modified-p))) + (unwind-protect + (save-excursion + (set-buffer vm-presentation-buffer) + (let ((buffer-read-only nil)) + (erase-buffer))) + (set-buffer-modified-p omodified))))) ;; try to avoid calling vm-su-labels if possible so as to ;; avoid loading vm-summary.el. (if (vm-labels-of (car vm-message-pointer)) @@ -295,6 +309,30 @@ 'vm-message-list) (set-buffer vm-summary-buffer) (set-buffer-modified-p modified)))) + (if vm-presentation-buffer + (let ((modified (buffer-modified-p))) + (save-excursion + (vm-copy-local-variables vm-presentation-buffer + 'vm-ml-message-new + 'vm-ml-message-unread + 'vm-ml-message-read + 'vm-ml-message-edited + 'vm-ml-message-replied + 'vm-ml-message-forwarded + 'vm-ml-message-filed + 'vm-ml-message-written + 'vm-ml-message-deleted + 'vm-ml-message-marked + 'vm-ml-message-number + 'vm-ml-highest-message-number + 'vm-folder-read-only + 'vm-folder-type + 'vm-virtual-folder-definition + 'vm-virtual-mirror + 'vm-ml-labels + 'vm-message-list) + (set-buffer vm-presentation-buffer) + (set-buffer-modified-p modified)))) (vm-force-mode-line-update)) (defun vm-update-summary-and-mode-line () @@ -440,7 +478,7 @@ This function works by examining the beginning of a folder. If optional arg FILE is present the type of FILE is returned instead. If optional second and third arg START and END are provided, -vm-get-folder-type will examine the the text between those buffer +vm-get-folder-type will examine the text between those buffer positions. START and END default to 1 and (buffer-size) + 1. Returns @@ -939,15 +977,17 @@ ;; ;; header-alist will contain an assoc list version of ;; keep-list. For messages associated with a folder - ;; buffer: when a matching header is found, the header - ;; is stuffed into its corresponding assoc cell and the - ;; header text is deleted from the buffer. After all - ;; the visible headers have been collected, they are - ;; inserted into the buffer in a clump at the end of - ;; the header section. Unmatched headers are skipped over. + ;; buffer: when a matching header is found, the + ;; header's start and end positions are added to its + ;; corresponding assoc cell. The positions of unwanted + ;; headers are remember also so that they can be copied + ;; to the top of the message, to be out of sight after + ;; narrowing. Once the positions have all been + ;; recorded a new copy of the headers is inserted in + ;; the proper order and the old headers are deleted. ;; - ;; For free standing messages, unmatched headers are - ;; stripped from the message. + ;; For free standing messages, unwanted headers are + ;; stripped from the message, unremembered. (vm-save-restriction (let ((header-alist (vm-build-header-order-alist keep-list)) (buffer-read-only nil) @@ -961,6 +1001,10 @@ ;; in a mail context reordering headers is harmless. (buffer-file-name nil) (case-fold-search t) + (unwanted-list nil) + unwanted-tail + new-header-start + old-header-start (old-buffer-modified-p (buffer-modified-p))) (unwind-protect (progn @@ -987,6 +1031,7 @@ (vm-headers-of message) (vm-text-of message)) (goto-char (point-min)))) + (setq old-header-start (point)) (while (and (not (= (following-char) ?\n)) (vm-match-header)) (setq end-of-header (vm-matched-header-end) @@ -998,50 +1043,69 @@ ;; discard-regexp is matched (if (or (and (null list) (null discard-regexp)) (and discard-regexp (looking-at discard-regexp))) - ;; skip the unwanted header if doing + ;; delete the unwanted header if not doing ;; work for a folder buffer, otherwise - ;; discard the header. - (if message - (goto-char end-of-header) - (delete-region (point) end-of-header)) + ;; remember the start and end of the + ;; unwanted header so we can copy it + ;; later. + (if (not message) + (delete-region (point) end-of-header) + (if (null unwanted-list) + (setq unwanted-list + (cons (point) (cons end-of-header nil)) + unwanted-tail unwanted-list) + (if (= (point) (car (cdr unwanted-tail))) + (setcar (cdr unwanted-tail) + end-of-header) + (setcdr (cdr unwanted-tail) + (cons (point) + (cons end-of-header nil))) + (setq unwanted-tail (cdr (cdr unwanted-tail))))) + (goto-char end-of-header)) ;; got a match - ;; stuff the header into the cdr of the - ;; returned alist element + ;; stuff the start and end of the header + ;; into the cdr of the returned alist + ;; element. (if list - (if (cdr list) - (setcdr list - (concat - (cdr list) - (buffer-substring (point) - end-of-header))) - (setcdr list (buffer-substring (point) - end-of-header))) + ;; reverse point and end-of-header. + ;; list will be nreversed later. + (setcdr list (cons end-of-header + (cons (point) + (cdr list)))) + ;; reverse point and end-of-header. + ;; list will be nreversed later. (setq extras - (cons (buffer-substring (point) end-of-header) - extras))) - (delete-region (point) end-of-header))) + (cons end-of-header + (cons (point) extras)))) + (goto-char end-of-header))) + (setq new-header-start (point)) + (while unwanted-list + (insert-buffer-substring (current-buffer) + (car unwanted-list) + (car (cdr unwanted-list))) + (setq unwanted-list (cdr (cdr unwanted-list)))) ;; remember the offset of where the visible ;; header start so we can initialize the ;; vm-vheaders-of field later. (if message - (setq vheader-offset (1- (point)))) - ;; now dump out the headers we saved. - ;; the keep-list headers go first. - (setq list header-alist) - (while list - (if (cdr (car list)) - (progn - (insert (cdr (car list))) - (setcdr (car list) nil))) - (setq list (cdr list))) + (setq vheader-offset (- (point) new-header-start))) + (while header-alist + (setq list (nreverse (cdr (car header-alist)))) + (while list + (insert-buffer-substring (current-buffer) + (car list) + (car (cdr list))) + (setq list (cdr (cdr list)))) + (setq header-alist (cdr header-alist))) ;; now the headers that were not explicitly ;; undesirable, if any. - (if extras - (progn - (setq extras (nreverse extras)) - (while extras - (insert (car extras)) - (setq extras (cdr extras))))) + (setq extras (nreverse extras)) + (while extras + (insert-buffer-substring (current-buffer) + (car extras) + (car (cdr extras))) + (setq extras (cdr (cdr extras)))) + (delete-region old-header-start new-header-start) ;; update the folder buffer if we're supposed to. ;; lock out interrupts. (if message @@ -1473,8 +1537,6 @@ attributes cache (case-fold-search t) (buffer-read-only nil) - ;; don't truncate the printing of large Lisp objects - (print-length nil) opoint ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock @@ -1533,6 +1595,28 @@ (vm-set-modflag-of m nil)) (set-buffer-modified-p old-buffer-modified-p)))))) +(defun vm-stuff-folder-attributes (&optional abort-if-input-pending) + (let ((newlist nil) mp) + ;; stuff the attributes of messages that need it. + ;; build a list of messages that need their attributes stuffed + (setq mp vm-message-list) + (while mp + (if (vm-modflag-of (car mp)) + (setq newlist (cons (car mp) newlist))) + (setq mp (cdr mp))) + ;; now sort the list by physical order so that we + ;; reduce the amount of gap motion induced by modifying + ;; the buffer. what we want to avoid is updating + ;; message 3, then 234, then 10, then 500, thus causing + ;; large chunks of memory to be copied repeatedly as + ;; the gap moves to accomodate the insertions. + (let ((vm-key-functions '(vm-sort-compare-physical-order-r))) + (setq mp (sort newlist 'vm-sort-compare-xxxxxx))) + (while (and mp (or (not abort-if-input-pending) (not (input-pending-p)))) + (vm-stuff-attributes (car mp)) + (setq mp (cdr mp))) + (if mp nil t))) + ;; we can be a bit lazy in this function since it's only called ;; from within vm-stuff-attributes. we don't worry about ;; restoring the modified flag, setting buffer-read-only, or @@ -1655,8 +1739,6 @@ ;; oh well, no way around this. (insert vm-labels-header " " (let ((print-escape-newlines t) - ;; don't truncate the printing of large Lisp objects - (print-length nil) (list nil)) (mapatoms (function (lambda (sym) @@ -1717,8 +1799,6 @@ (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) - ;; don't truncate the printing of large Lisp objects - (print-length nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking @@ -1765,8 +1845,6 @@ (case-fold-search t) (print-escape-newlines t) lim - ;; don't truncate the printing of large Lisp objects - (print-length nil) (buffer-read-only nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock @@ -1810,8 +1888,6 @@ (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) - ;; don't truncate the printing of large Lisp objects - (print-length nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking @@ -1937,8 +2013,11 @@ (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) - (run-hooks 'vm-quit-hook) + (save-excursion (run-hooks 'vm-quit-hook)) + + (vm-garbage-collect-message) (vm-display nil nil '(vm-quit-just-bury) '(vm-quit-just-bury quitting)) @@ -1946,6 +2025,10 @@ (vm-display vm-summary-buffer nil nil nil)) (if vm-summary-buffer (vm-bury-buffer vm-summary-buffer)) + (if vm-presentation-buffer-handle + (vm-display vm-presentation-buffer-handle nil nil nil)) + (if vm-presentation-buffer-handle + (vm-bury-buffer vm-presentation-buffer-handle)) (vm-display (current-buffer) nil nil nil) (vm-bury-buffer (current-buffer))) @@ -1957,15 +2040,22 @@ (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) - (run-hooks 'vm-quit-hook) + (save-excursion (run-hooks 'vm-quit-hook)) + + (vm-garbage-collect-message) (vm-display nil nil '(vm-quit-just-iconify) '(vm-quit-just-iconify quitting)) - (vm-bury-buffer (current-buffer)) - (if vm-summary-buffer - (vm-bury-buffer vm-summary-buffer)) - (vm-iconify-frame)) + (let ((summary-buffer vm-summary-buffer) + (pres-buffer vm-presentation-buffer-handle)) + (vm-bury-buffer (current-buffer)) + (if summary-buffer + (vm-bury-buffer summary-buffer)) + (if pres-buffer + (vm-bury-buffer pres-buffer)) + (vm-iconify-frame))) (defun vm-quit-no-change () "Quit visiting the current folder without saving changes made to the folder." @@ -1979,11 +2069,13 @@ (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-display nil nil '(vm-quit vm-quit-no-change) (list this-command 'quitting)) (let ((virtual (eq major-mode 'vm-virtual-mode))) (cond ((and (not virtual) no-change (buffer-modified-p) + (or buffer-file-name buffer-offer-save) (not (zerop vm-messages-not-on-disk)) ;; Folder may have been saved with C-x C-s and attributes may have ;; been changed after that; in that case vm-messages-not-on-disk @@ -2000,14 +2092,20 @@ (if (= 1 vm-messages-not-on-disk) "" "s"))))) (error "Aborted")) ((and (not virtual) - no-change (buffer-modified-p) vm-confirm-quit + no-change + (or buffer-file-name buffer-offer-save) + (buffer-modified-p) + vm-confirm-quit (not (y-or-n-p "There are unsaved changes, quit anyway? "))) (error "Aborted")) ((and (eq vm-confirm-quit t) (not (y-or-n-p "Do you really want to quit? "))) (error "Aborted"))) - (run-hooks 'vm-quit-hook) + (save-excursion (run-hooks 'vm-quit-hook)) + + (vm-garbage-collect-message) + (vm-garbage-collect-folder) (vm-virtual-quit) (if (and (not no-change) (not virtual)) @@ -2016,45 +2114,71 @@ (vm-unsaved-message "Quitting...") (or vm-folder-read-only (eq major-mode 'vm-virtual-mode) (vm-change-all-new-to-unread)))) - (if (and (buffer-modified-p) (not no-change) (not virtual)) + (if (and (buffer-modified-p) + (or buffer-file-name buffer-offer-save) + (not no-change) + (not virtual)) (vm-save-folder)) (vm-unsaved-message "") (let ((summary-buffer vm-summary-buffer) + (pres-buffer vm-presentation-buffer-handle) (mail-buffer (current-buffer))) (if summary-buffer (progn - (vm-display vm-summary-buffer nil nil nil) + (vm-display summary-buffer nil nil nil) (kill-buffer summary-buffer))) + (if pres-buffer + (progn + (vm-display pres-buffer nil nil nil) + (kill-buffer pres-buffer))) (set-buffer mail-buffer) (vm-display mail-buffer nil nil nil) ;; vm-display is not supposed to change the current buffer. - ;; still better to be safe here. + ;; still it's better to be safe here. (set-buffer mail-buffer) (set-buffer-modified-p nil) (kill-buffer (current-buffer))) (vm-update-summary-and-mode-line))) (defun vm-start-itimers-if-needed () - (if (or (natnump vm-flush-interval) - (natnump vm-auto-get-new-mail)) - (progn - (if (null - (condition-case data - (progn (require 'itimer) t) - (error nil))) - (setq vm-flush-interval t - vm-auto-get-new-mail t) - (and (natnump vm-flush-interval) (not (get-itimer "vm-flush")) - (start-itimer "vm-flush" 'vm-flush-itimer-function - vm-flush-interval nil)) - (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail")) - (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function - vm-auto-get-new-mail nil)))))) + (cond ((and (not (natnump vm-flush-interval)) + (not (natnump vm-auto-get-new-mail)))) + ((condition-case data + (progn (require 'itimer) t) + (error nil)) + (and (natnump vm-flush-interval) (not (get-itimer "vm-flush")) + (start-itimer "vm-flush" 'vm-flush-itimer-function + vm-flush-interval nil)) + (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail")) + (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function + vm-auto-get-new-mail nil))) + ((condition-case data + (progn (require 'timer) t) + (error nil)) + (let (timer) + (and (natnump vm-flush-interval) + (setq timer (run-at-time vm-flush-interval vm-flush-interval + 'vm-flush-itimer-function nil)) + (timer-set-function timer 'vm-flush-itimer-function + (list timer))) + (and (natnump vm-auto-get-new-mail) + (setq timer (run-at-time vm-auto-get-new-mail + vm-auto-get-new-mail + 'vm-get-mail-itimer-function nil)) + (timer-set-function timer 'vm-get-mail-itimer-function + (list timer))))) + (t + (setq vm-flush-interval t + vm-auto-get-new-mail t)))) ;; support for numeric vm-auto-get-new-mail -(defun vm-get-mail-itimer-function () +;; if timer argument is present, this means we're using the Emacs +;; 'timer package rather than the 'itimer package. +(defun vm-get-mail-itimer-function (&optional timer) (if (integerp vm-auto-get-new-mail) - (set-itimer-restart current-itimer vm-auto-get-new-mail)) + (if timer + (timer-set-time timer (current-time) vm-auto-get-new-mail) + (set-itimer-restart current-itimer vm-auto-get-new-mail))) (let ((b-list (buffer-list))) (while (and (not (input-pending-p)) b-list) (save-excursion @@ -2079,13 +2203,19 @@ (setq b-list (cdr b-list))))) ;; support for numeric vm-flush-interval -(defun vm-flush-itimer-function () +;; if timer argument is present, this means we're using the Emacs +;; 'timer package rather than the 'itimer package. +(defun vm-flush-itimer-function (&optional timer) (if (integerp vm-flush-interval) - (set-itimer-restart current-itimer vm-flush-interval)) + (if timer + (timer-set-time timer (current-time) vm-flush-interval) + (set-itimer-restart current-itimer vm-flush-interval))) ;; if no vm-mode buffers are found, we might as well shut down the ;; flush itimer. (if (not (vm-flush-cached-data)) - (set-itimer-restart current-itimer nil))) + (if timer + (cancel-timer timer) + (set-itimer-restart current-itimer nil)))) ;; flush cached data in all vm-mode buffers. ;; returns non-nil if any vm-mode buffers were found. @@ -2099,16 +2229,12 @@ (setq found-one t) (if (not (eq vm-modification-counter vm-flushed-modification-counter)) - (let ((mp vm-message-list)) + (progn (vm-stuff-summary) (vm-stuff-labels) (and vm-message-order-changed (vm-stuff-message-order)) - (while (and mp (not (input-pending-p))) - (if (vm-modflag-of (car mp)) - (vm-stuff-attributes (car mp))) - (setq mp (cdr mp))) - (and (null mp) + (and (vm-stuff-folder-attributes t) (setq vm-flushed-modification-counter vm-modification-counter)))))) (setq buf-list (cdr buf-list))) @@ -2124,23 +2250,19 @@ ;; the stuff routines clean up after themselves, but should remain ;; as a safeguard against the time when other stuff is added here. (vm-save-restriction - (let ((mp vm-message-list) - (buffer-read-only)) - (while mp - (if (vm-modflag-of (car mp)) - (vm-stuff-attributes (car mp))) - (setq mp (cdr mp))) - (if vm-message-list - (progn - ;; get summary cache up-to-date - (vm-update-summary-and-mode-line) - (vm-stuff-bookmark) - (vm-stuff-header-variables) - (vm-stuff-labels) - (vm-stuff-summary) - (and vm-message-order-changed - (vm-stuff-message-order)))) - nil )))) + (let ((buffer-read-only)) + (vm-stuff-folder-attributes nil) + (if vm-message-list + (progn + ;; get summary cache up-to-date + (vm-update-summary-and-mode-line) + (vm-stuff-bookmark) + (vm-stuff-header-variables) + (vm-stuff-labels) + (vm-stuff-summary) + (and vm-message-order-changed + (vm-stuff-message-order)))) + nil )))) (defun vm-save-buffer (prefix) (interactive "P") @@ -2177,14 +2299,10 @@ (if (eq major-mode 'vm-virtual-mode) (vm-virtual-save-folder prefix) (if (buffer-modified-p) - (let (mp) + (let (mp (newlist nil)) ;; stuff the attributes of messages that need it. (vm-unsaved-message "Stuffing attributes...") - (setq mp vm-message-list) - (while mp - (if (vm-modflag-of (car mp)) - (vm-stuff-attributes (car mp))) - (setq mp (cdr mp))) + (vm-stuff-folder-attributes nil) ;; stuff bookmark and header variable values (if vm-message-list (progn @@ -2435,8 +2553,31 @@ ;; a timer process might try to start retrieving mail ;; before we finish. block these attempts. (vm-block-new-mail t) + (fallback-triples nil) crash in maildrop popdrop (got-mail nil)) + (cond ((and buffer-file-name + (consp vm-spool-file-suffixes) + (stringp vm-crash-box-suffix)) + (setq fallback-triples + (mapcar (function + (lambda (suffix) + (list buffer-file-name + (concat buffer-file-name suffix) + (concat buffer-file-name + vm-crash-box-suffix)))) + vm-spool-file-suffixes)))) + (cond ((and buffer-file-name + vm-make-spool-file-name vm-make-crash-box-name) + (setq fallback-triples + (ncons fallback-triples + (list (list buffer-file-name + (save-excursion + (funcall vm-make-spool-file-name + buffer-file-name)) + (save-excursion + (funcall vm-make-crash-box-name + buffer-file-name)))))))) (cond ((null (vm-spool-files)) (setq triples (list (list vm-primary-inbox @@ -2449,6 +2590,7 @@ (vm-spool-files)))) ((consp (car (vm-spool-files))) (setq triples (vm-spool-files)))) + (setq triples (append triples fallback-triples)) (while triples (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory) maildrop (nth 1 (car triples)) @@ -2573,7 +2715,10 @@ (message "No messages gathered.")))))) ;; returns non-nil if there were any new messages -(defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order) +(defun vm-assimilate-new-messages (&optional + dont-read-attributes + gobble-order + labels) (let ((tail-cons (vm-last vm-message-list)) b-list new-messages) (save-excursion @@ -2606,6 +2751,12 @@ ;; vm-assimilate-new-messages returns this value so it must ;; not be mangled. (setq new-messages (copy-sequence new-messages)) + ;; add the labels + (if (and labels vm-burst-digest-messages-inherit-labels) + (let ((mp new-messages)) + (while mp + (vm-set-labels-of (car mp) (copy-sequence labels)) + (setq mp (cdr mp))))) (if vm-summary-show-threads (progn ;; get numbering and summary of new messages done now @@ -2688,7 +2839,7 @@ (defun vm-display-startup-message () (if (sit-for 5) (let ((lines vm-startup-message-lines)) - (message "VM %s, Copyright (C) 1996 Kyle E. Jones; type ? for help" + (message "VM %s, Copyright (C) 1997 Kyle E. Jones; type ? for help" vm-version) (setq vm-startup-message-displayed t) (while (and (sit-for 4) lines) @@ -2702,7 +2853,7 @@ (progn (and vm-init-file (load vm-init-file (not interactive) (not interactive) t)) - (and vm-options-file (load vm-options-file t t t)))) + (and vm-preferences-file (load vm-preferences-file t t t)))) (setq vm-init-file-loaded t) (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) @@ -2744,10 +2895,16 @@ mode-line-format vm-mode-line-format mode-name "VM" ;; must come after the setting of major-mode - mode-popup-menu (and vm-use-menus + mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t + ;; If the user quits a vm-mode buffer, the default action is + ;; to kill the buffer. Make a note that we should offer to + ;; save this buffer even if it has no file associated with it. + ;; We have no idea of the value of the data in the buffer + ;; before it was put into vm-mode. + buffer-offer-save t require-final-newline nil vm-thread-obarray nil vm-thread-subject-obarray nil @@ -2767,6 +2924,15 @@ (use-local-map vm-mode-map) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) + (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) + (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) + ;; avoid the XEmacs file dialog box. + (defvar should-use-dialog-box) + (make-local-variable 'should-use-dialog-box) + (setq should-use-dialog-box nil) + ;; mail folders are precious. protect them by default. + (make-local-variable 'file-precious-flag) + (setq file-precious-flag t) (run-hooks 'vm-mode-hook) ;; compatibility (run-hooks 'vm-mode-hooks)) @@ -2881,6 +3047,24 @@ (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer)))) (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type))) +(defun vm-garbage-collect-folder () + (save-excursion + (while vm-folder-garbage-alist + (condition-case nil + (funcall (cdr (car vm-folder-garbage-alist)) + (car (car vm-folder-garbage-alist))) + (error nil)) + (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist))))) + +(defun vm-garbage-collect-message () + (save-excursion + (while vm-message-garbage-alist + (condition-case nil + (funcall (cdr (car vm-message-garbage-alist)) + (car (car vm-message-garbage-alist))) + (error nil)) + (setq vm-message-garbage-alist (cdr vm-message-garbage-alist))))) + (if (not (memq 'vm-write-file-hook write-file-hooks)) (setq write-file-hooks (cons 'vm-write-file-hook write-file-hooks))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-mark.el --- a/lisp/vm/vm-mark.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-mark.el Mon Aug 13 09:13:56 2007 +0200 @@ -98,6 +98,61 @@ '(vm-unmark-message marking-message)) (vm-update-summary-and-mode-line)) +(defun vm-mark-summary-region () + "Mark all messages with summary lines contained in the region." + (interactive) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (if (null vm-summary-buffer) + (error "No summary.")) + (set-buffer vm-summary-buffer) + (if (not (mark)) + (error "The region is not active now")) + (vm-mark-or-unmark-summary-region t) + (vm-display nil nil '(vm-mark-summary-region) + '(vm-mark-summary-region marking-message)) + (vm-update-summary-and-mode-line)) + +(defun vm-unmark-summary-region () + "Remove marks from messages with summary lines contained in the region." + (interactive) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (if (null vm-summary-buffer) + (error "No summary.")) + (set-buffer vm-summary-buffer) + (if (not (mark)) + (error "The region is not active now")) + (vm-mark-or-unmark-summary-region nil) + (vm-display nil nil '(vm-unmark-summary-region) + '(vm-unmark-summary-region marking-message)) + (vm-update-summary-and-mode-line)) + +(defun vm-mark-or-unmark-summary-region (markit) + ;; The folder buffers copy of vm-message-list has already been + ;; propagated to the summary buffer. + (let ((mp vm-message-list) + (beg (point)) + (end (mark)) + tmp m) + (if (> beg end) + (setq tmp beg beg end end tmp)) + (while mp + (setq m (car mp)) + (if (not (eq (not markit) (not (vm-mark-of m)))) + (if (or (and (> (vm-su-end-of m) beg) + (< (vm-su-end-of m) end)) + (and (>= (vm-su-start-of m) beg) + (< (vm-su-start-of m) end)) + (and (>= beg (vm-su-start-of m)) + (< beg (vm-su-end-of m)))) + (progn + (vm-set-mark-of m markit) + (vm-mark-for-summary-update m t)))) + (setq mp (cdr mp))))) + (defun vm-mark-or-unmark-messages-with-selector (val selector arg) (let ((mlist vm-message-list) (virtual (eq major-mode 'vm-virtual-mode)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-menu.el --- a/lisp/vm/vm-menu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-menu.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Menu related functions and commands -;;; Copyright (C) 1995 Kyle E. Jones +;;; Copyright (C) 1995, 1997 Kyle E. Jones ;;; ;;; Folders menu derived from ;;; vm-folder-menu.el @@ -123,6 +123,7 @@ ["Pipe to Command" vm-pipe-message-to-command vm-message-list] "---" ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list] + ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)] )))) (defconst vm-menu-motion-menu @@ -178,6 +179,7 @@ ["Retry Bounced Message" vm-resend-bounced-message vm-message-list] ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list] ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list] + ["Send MIME Digest" vm-send-mime-digest vm-message-list] )) (defconst vm-menu-mark-menu @@ -281,8 +283,36 @@ ["Insert Signature" mail-signature t] ["Insert File..." insert-file t] ["Insert Buffer..." insert-buffer t] + "----" + "MIME:" + "----" + [" Attach File..." vm-mime-attach-file vm-send-using-mime] + [" Attach MIME File..." vm-mime-attach-mime-file vm-send-using-mime] + [" Encode MIME, But Don't Send" vm-mime-encode-composition + (and vm-send-using-mime + (null (vm-mail-mode-get-header-contents "MIME-Version:")))] + [" Preview MIME Before Sending" vm-mime-preview-composition + vm-send-using-mime] )))) +(defconst vm-menu-mime-dispose-menu + (let ((title (if (vm-menu-fsfemacs-menus-p) + (list "Send MIME body to ..." + "Send MIME body to ..." + "---" + "---") + (list "Send MIME body to ...")))) + (append + title + (list ["File" (vm-mime-run-display-function-at-point + 'vm-mime-send-body-to-file) t] + ["Shell Pipeline (display output)" + (vm-mime-run-display-function-at-point + 'vm-mime-pipe-body-to-command) t] + ["Shell Pipeline (discard output)" + (vm-mime-run-display-function-at-point + 'vm-mime-pipe-body-to-command-discard-output) t])))) + (defconst vm-menu-url-browser-menu (let ((title (if (vm-menu-fsfemacs-menus-p) (list "Send URL to ..." @@ -369,7 +399,7 @@ vm-menu-label-menu vm-menu-sort-menu vm-menu-virtual-menu - vm-menu-undo-menu +;; vm-menu-undo-menu vm-menu-dispose-menu "---" "---" @@ -420,6 +450,16 @@ (vm-select-folder-buffer) vm-undo-record-list)) +(defun vm-menu-can-decode-mime-p () + (save-excursion + (vm-check-for-killed-folder) + (vm-select-folder-buffer) + (and vm-display-using-mime + vm-message-pointer + vm-presentation-buffer + (not vm-mime-decoded) + (not (vm-mime-plain-message-p (car vm-message-pointer)))))) + (defun vm-menu-yank-original () (interactive) (save-excursion @@ -508,6 +548,10 @@ ;; url browser menu (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil vm-menu-url-browser-menu) + ;; mime dispose menu + (vm-easy-menu-define vm-menu-fsfemacs-mime-dispose-menu + (list dummy) nil + vm-menu-mime-dispose-menu) ;; block the global menubar entries in the map so that VM ;; can take over the menubar if necessary. (define-key map [rootmenu] (make-sparse-keymap)) @@ -553,7 +597,7 @@ (menu-list (if (consp vm-use-menus) (reverse vm-use-menus) - (list 'help nil 'dispose 'undo 'virtual 'sort + (list 'help nil 'dispose 'virtual 'sort 'label 'mark 'send 'motion 'folder)))) (while menu-list (if (null (car menu-list)) @@ -624,12 +668,16 @@ (vm-menu-popup-url-browser-menu event)) ((setq menu (overlay-get (car o-list) 'vm-header)) (setq found t) - (vm-menu-popup-fsfemacs-menu event menu))) + (vm-menu-popup-fsfemacs-menu event menu)) + ((overlay-get (car o-list) 'vm-mime-layout) + (setq found t) + (vm-menu-popup-mime-dispose-menu event))) (setq o-list (cdr o-list))) (and (not found) (vm-menu-popup-fsfemacs-menu event)))))) ;; to quiet the byte-compiler (defvar vm-menu-fsfemacs-url-browser-menu) +(defvar vm-menu-fsfemacs-mime-dispose-menu) (defun vm-menu-popup-url-browser-menu (event) (interactive "e") @@ -647,6 +695,22 @@ (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-url-browser-menu)))) +(defun vm-menu-popup-mime-dispose-menu (event) + (interactive "e") + (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) + ;; Must select window instead of just set-buffer because + ;; popup-menu returns before the user has made a + ;; selection. This will cause the command loop to + ;; resume which might undo what set-buffer does. + (select-window (event-window event)) + (and (event-point event) (goto-char (event-point event))) + (popup-menu vm-menu-mime-dispose-menu)) + ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) + (set-buffer (window-buffer (posn-window (event-start event)))) + (goto-char (posn-point (event-start event))) + (vm-menu-popup-fsfemacs-menu + event vm-menu-fsfemacs-mime-dispose-menu)))) + ;; to quiet the byte-compiler (defvar vm-menu-fsfemacs-mail-menu) (defvar vm-menu-fsfemacs-dispose-popup-menu) @@ -696,6 +760,9 @@ (cond ((vm-menu-xemacs-menus-p) (if (null (car (find-menu-item current-menubar '("XEmacs")))) (set-buffer-menubar vm-menu-vm-menubar) + ;; copy the current menubar in case it has been changed. + (make-local-variable 'vm-menu-vm-menubar) + (setq vm-menu-vm-menubar (copy-sequence current-menubar)) (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) (condition-case nil (add-menu-button nil vm-menu-vm-button nil) @@ -704,7 +771,12 @@ (vm-menu-set-menubar-dirty-flag) (vm-check-for-killed-summary) (and vm-summary-buffer - (vm-menu-toggle-menubar vm-summary-buffer))) + (save-excursion + (vm-menu-toggle-menubar vm-summary-buffer))) + (vm-check-for-killed-presentation) + (and vm-presentation-buffer-handle + (save-excursion + (vm-menu-toggle-menubar vm-presentation-buffer-handle)))) ((vm-menu-fsfemacs-menus-p) (if (not (eq (lookup-key vm-mode-map [menu-bar]) (lookup-key vm-mode-menu-map [rootmenu vm]))) @@ -719,7 +791,9 @@ (defun vm-menu-install-menubar () (cond ((vm-menu-xemacs-menus-p) (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar)) - (set-buffer-menubar vm-menu-vm-menubar)) + (set-buffer-menubar vm-menu-vm-menubar) + (run-hooks 'vm-menu-setup-hook) + (setq vm-menu-vm-menubar current-menubar)) ((and (vm-menu-fsfemacs-menus-p) ;; menus only need to be installed once for FSF Emacs (not (fboundp 'vm-menu-undo-menu))) @@ -750,7 +824,8 @@ (cond ((vm-menu-xemacs-menus-p) ;; mail-mode doesn't have mode-popup-menu bound to ;; mouse-3 by default. fix that. - (define-key vm-mail-mode-map 'button3 'popup-mode-menu) + (if vm-popup-menu-on-mouse-3 + (define-key vm-mail-mode-map 'button3 'popup-mode-menu)) ;; put menu on menubar also. (if (vm-menu-xemacs-global-menubar) (progn @@ -764,8 +839,9 @@ ;; Poorly. ;;(define-key vm-mail-mode-map [menu-bar mail] ;; (cons "Mail" vm-menu-fsfemacs-mail-menu)) - (define-key vm-mail-mode-map [down-mouse-3] - 'vm-menu-popup-mode-menu)))) + (if vm-popup-menu-on-mouse-3 + (define-key vm-mail-mode-map [down-mouse-3] + 'vm-menu-popup-mode-menu))))) (defun vm-menu-install-menus () (cond ((consp vm-use-menus) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-message.el --- a/lisp/vm/vm-message.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-message.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Macros and functions dealing with accessing VM message struct fields -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -81,6 +81,11 @@ ;; summary for unmirrored virtual message (defmacro vm-virtual-summary-of (message) (list 'aref (list 'aref message 1) 15)) +;; MIME layout information; types, ids, positions, etc. of all MIME entities +(defmacro vm-mime-layout-of (message) + (list 'aref (list 'aref message 1) 16)) +(defmacro vm-mime-encoded-header-flag-of (message) + (list 'aref (list 'aref message 1) 17)) ;; message attribute vector (defmacro vm-attributes-of (message) (list 'aref message 2)) (defmacro vm-new-flag (message) (list 'aref (list 'aref message 2) 0)) @@ -202,6 +207,10 @@ (list 'aset (list 'aref message 1) 14 data)) (defmacro vm-set-virtual-summary-of (message summ) (list 'aset (list 'aref message 1) 15 summ)) +(defmacro vm-set-mime-layout-of (message layout) + (list 'aset (list 'aref message 1) 16 layout)) +(defmacro vm-set-mime-encoded-header-flag-of (message flag) + (list 'aset (list 'aref message 1) 17 flag)) (defmacro vm-set-attributes-of (message attrs) (list 'aset message 2 attrs)) ;; The other routines in attributes group are part of the undo system. (defun vm-set-edited-flag-of (message flag) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-mime.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vm/vm-mime.el Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,2495 @@ +;;; MIME support functions +;;; Copyright (C) 1997 Kyle E. Jones +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +(provide 'vm-mime) + +(defun vm-mime-error (&rest args) + (signal 'vm-mime-error (list (apply 'format args))) + (error "can't return from vm-mime-error")) + +(if (fboundp 'define-error) + (define-error 'vm-mime-error "MIME error") + (put 'vm-mime-error 'error-conditions '(vm-mime-error error)) + (put 'vm-mime-error 'error-message "MIME error")) + +(defun vm-mm-layout-type (e) (aref e 0)) +(defun vm-mm-layout-encoding (e) (aref e 1)) +(defun vm-mm-layout-id (e) (aref e 2)) +(defun vm-mm-layout-description (e) (aref e 3)) +(defun vm-mm-layout-disposition (e) (aref e 4)) +(defun vm-mm-layout-header-start (e) (aref e 5)) +(defun vm-mm-layout-body-start (e) (aref e 6)) +(defun vm-mm-layout-body-end (e) (aref e 7)) +(defun vm-mm-layout-parts (e) (aref e 8)) +(defun vm-mm-layout-cache (e) (aref e 9)) + +(defun vm-set-mm-layout-cache (e c) (aset e 8 c)) + +(defun vm-mm-layout (m) + (or (vm-mime-layout-of m) + (progn (vm-set-mime-layout-of + m + (condition-case data + (vm-mime-parse-entity m) + (vm-mime-error (apply 'message (cdr data))))) + (vm-mime-layout-of m)))) + +(defun vm-mm-encoded-header (m) + (or (vm-mime-encoded-header-flag-of m) + (progn (setq m (vm-real-message-of m)) + (vm-set-mime-encoded-header-flag-of + m + (save-excursion + (set-buffer (vm-buffer-of m)) + (save-excursion + (save-restriction + (widen) + (goto-char (vm-headers-of m)) + (or (re-search-forward vm-mime-encoded-word-regexp + (vm-text-of m) t) + 'none))))) + (vm-mime-encoded-header-flag-of m)))) + +(defun vm-mime-Q-decode-region (start end) + (let ((buffer-read-only nil)) + (subst-char-in-region start end ?_ (string-to-char " ") t) + (vm-mime-qp-decode-region start end))) + +(fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region) + +(defun vm-mime-Q-encode-region (start end) + (let ((buffer-read-only nil)) + (subst-char-in-region start end (string-to-char " ") ?_ t) + (vm-mime-qp-encode-region start end))) + +(fset 'vm-mime-B-encode-region 'vm-mime-base64-encode-region) + +(defun vm-mime-Q-decode-string (string) + (vm-with-string-as-region string 'vm-mime-Q-decode-region)) + +(defun vm-mime-B-decode-string (string) + (vm-with-string-as-region string 'vm-mime-B-decode-region)) + +(defun vm-mime-Q-encode-string (string) + (vm-with-string-as-region string 'vm-mime-Q-encode-region)) + +(defun vm-mime-B-encode-string (string) + (vm-with-string-as-region string 'vm-mime-B-encode-region)) + +(defun vm-mime-crlf-to-lf-region (start end) + (let ((buffer-read-only nil)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (search-forward "\r\n" nil t) + (delete-char -2) + (insert "\n")))))) + +(defun vm-mime-lf-to-crlf-region (start end) + (let ((buffer-read-only nil)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (search-forward "\n" nil t) + (delete-char -1) + (insert "\r\n")))))) + +(defun vm-mime-charset-decode-region (charset start end) + (let ((buffer-read-only nil) + (cell (vm-mime-charset-internally-displayable-p charset)) + (opoint (point))) + (cond ((and cell (vm-xemacs-mule-p) (eq (device-type) 'x)) + (decode-coding-region start end (car cell)))) + ;; In XEmacs 20.0 beta93 decode-coding-region moves point. + (goto-char opoint))) + +(defun vm-mime-transfer-decode-region (layout start end) + (let ((case-fold-search t) (crlf nil)) + (cond ((string-match "^base64$" (vm-mm-layout-encoding layout)) + (cond ((vm-mime-types-match "text" + (car (vm-mm-layout-type layout))) + (setq crlf t)) + ((vm-mime-types-match "message" + (car (vm-mm-layout-type layout))) + (setq crlf t))) + (vm-mime-base64-decode-region start end crlf)) + ((string-match "^quoted-printable$" + (vm-mm-layout-encoding layout)) + (vm-mime-qp-decode-region start end))))) + +(defun vm-mime-base64-decode-region (start end &optional crlf) + (vm-unsaved-message "Decoding base64...") + (let ((work-buffer nil) + (done nil) + (counter 0) + (bits 0) + (lim 0) inputpos + (non-data-chars (concat "^=" vm-mime-base64-alphabet))) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (if vm-mime-base64-decoder-program + (let* ((binary-process-output t) ; any text already has CRLFs + (status (apply 'vm-run-command-on-region + start end work-buffer + vm-mime-base64-decoder-program + vm-mime-base64-decoder-switches))) + (if (not (eq status t)) + (vm-mime-error "%s" (cdr status)))) + (goto-char start) + (skip-chars-forward non-data-chars end) + (while (not done) + (setq inputpos (point)) + (cond + ((> (skip-chars-forward vm-mime-base64-alphabet end) 0) + (setq lim (point)) + (while (< inputpos lim) + (setq bits (+ bits + (aref vm-mime-base64-alphabet-decoding-vector + (char-after inputpos)))) + (vm-increment counter) + (vm-increment inputpos) + (cond ((= counter 4) + (vm-insert-char (lsh bits -16) 1 nil work-buffer) + (vm-insert-char (logand (lsh bits -8) 255) 1 nil + work-buffer) + (vm-insert-char (logand bits 255) 1 nil work-buffer) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 6))))))) + (cond + ((= (point) end) + (if (not (zerop counter)) + (vm-mime-error "at least %d bits missing at end of base64 encoding" + (* (- 4 counter) 6))) + (setq done t)) + ((= (char-after (point)) 61) ; 61 is ASCII equals + (setq done t) + (cond ((= counter 1) + (vm-mime-error "at least 2 bits missing at end of base64 encoding")) + ((= counter 2) + (vm-insert-char (lsh bits -10) 1 nil work-buffer)) + ((= counter 3) + (vm-insert-char (lsh bits -16) 1 nil work-buffer) + (vm-insert-char (logand (lsh bits -8) 255) + 1 nil work-buffer)) + ((= counter 0) t))) + (t (skip-chars-forward non-data-chars end))))) + (and crlf + (save-excursion + (set-buffer work-buffer) + (vm-mime-crlf-to-lf-region (point-min) (point-max)))) + (or (markerp end) (setq end (vm-marker end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + (vm-unsaved-message "Decoding base64... done")) + +(defun vm-mime-base64-encode-region (start end &optional crlf) + (vm-unsaved-message "Encoding base64...") + (let ((work-buffer nil) + (counter 0) + (cols 0) + (bits 0) + (alphabet vm-mime-base64-alphabet) + inputpos) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (if crlf + (progn + (or (markerp end) (setq end (vm-marker end))) + (vm-mime-lf-to-crlf-region start end))) + (if vm-mime-base64-encoder-program + (let ((status (apply 'vm-run-command-on-region + start end work-buffer + vm-mime-base64-encoder-program + vm-mime-base64-encoder-switches))) + (if (not (eq status t)) + (vm-mime-error "%s" (cdr status)))) + (setq inputpos start) + (while (< inputpos end) + (setq bits (+ bits (char-after inputpos))) + (vm-increment counter) + (cond ((= counter 3) + (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil + work-buffer) + (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) + 1 nil work-buffer) + (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) + 1 nil work-buffer) + (vm-insert-char (aref alphabet (logand bits 63)) 1 nil + work-buffer) + (setq cols (+ cols 4)) + (cond ((= cols 72) + (vm-insert-char ?\n 1 nil work-buffer) + (setq cols 0))) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 8)))) + (vm-increment inputpos)) + ;; write out any remaining bits with appropriate padding + (if (= counter 0) + nil + (setq bits (lsh bits (- 16 (* 8 counter)))) + (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil + work-buffer) + (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) + 1 nil work-buffer) + (if (= counter 1) + (vm-insert-char ?= 2 nil work-buffer) + (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) + 1 nil work-buffer) + (vm-insert-char ?= 1 nil work-buffer))) + (if (> cols 0) + (vm-insert-char ?\n 1 nil work-buffer))) + (or (markerp end) (setq end (vm-marker end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + (vm-unsaved-message "Encoding base64... done")) + +(defun vm-mime-qp-decode-region (start end) + (vm-unsaved-message "Decoding quoted-printable...") + (let ((work-buffer nil) + (buf (current-buffer)) + (case-fold-search nil) + (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) + (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) + (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) + (?C . 12) (?D . 13) (?E . 14) (?F . 15))) + inputpos stop-point copy-point) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (goto-char start) + (setq inputpos start) + (while (< inputpos end) + (skip-chars-forward "^=\n" end) + (setq stop-point (point)) + (cond ((looking-at "\n") + ;; spaces or tabs before a hard line break must be ignored + (skip-chars-backward " \t") + (setq copy-point (point)) + (goto-char stop-point)) + (t (setq copy-point stop-point))) + (save-excursion + (set-buffer work-buffer) + (insert-buffer-substring buf inputpos copy-point)) + (cond ((= (point) end) t) + ((looking-at "\n") + (vm-insert-char ?\n 1 nil work-buffer) + (forward-char)) + (t ;; looking at = + (forward-char) + (cond ((looking-at "[0-9A-F][0-9A-F]") + (vm-insert-char (+ (* (cdr (assq (char-after (point)) + hex-digit-alist)) + 16) + (cdr (assq (char-after + (1+ (point))) + hex-digit-alist))) + 1 nil work-buffer) + (forward-char 2)) + ((looking-at "\n") ; soft line break + (forward-char)) + ((looking-at "\r") + ;; assume the user's goatfucking + ;; delivery software didn't convert + ;; from Internet's CRLF newline + ;; convention to the local LF + ;; convention. + (forward-char)) + ((looking-at "[ \t]") + ;; garbage added in transit + (skip-chars-forward " \t" end)) + (t (vm-mime-error "something other than line break or hex digits after = in quoted-printable encoding"))))) + (setq inputpos (point))) + (or (markerp end) (setq end (vm-marker end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + (vm-unsaved-message "Decoding quoted-printable... done")) + +(defun vm-mime-qp-encode-region (start end) + (vm-unsaved-message "Encoding quoted-printable...") + (let ((work-buffer nil) + (buf (current-buffer)) + (cols 0) + (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) + (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) + (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) + (?C . 12) (?D . 13) (?E . 14) (?F . 15))) + char inputpos) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (setq inputpos start) + (while (< inputpos end) + (setq char (char-after inputpos)) + (cond ((= char ?\n) + (vm-insert-char char 1 nil work-buffer) + (setq cols 0)) + ((and (= char 32) (not (= ?\n (char-after (1+ inputpos))))) + (vm-insert-char char 1 nil work-buffer) + (vm-increment cols)) + ((or (< char 33) (> char 126) (= char 61)) + (vm-insert-char ?= 1 nil work-buffer) + (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist)) + 1 nil work-buffer) + (vm-insert-char (car (rassq (logand char 15) + hex-digit-alist)) + 1 nil work-buffer) + (setq cols (+ cols 3))) + (t (vm-insert-char char 1 nil work-buffer) + (vm-increment cols))) + (cond ((> cols 70) + (vm-insert-char ?= 1 nil work-buffer) + (vm-insert-char ?\n 1 nil work-buffer) + (setq cols 0))) + (vm-increment inputpos)) + (or (markerp end) (setq end (vm-marker end))) + (goto-char start) + (insert-buffer-substring work-buffer) + (delete-region (point) end)) + (and work-buffer (kill-buffer work-buffer)))) + (vm-unsaved-message "Encoding quoted-printable... done")) + +(defun vm-decode-mime-message-headers (m) + (let ((case-fold-search t) + (buffer-read-only nil) + charset encoding match-start match-end start end) + (save-excursion + (goto-char (vm-headers-of m)) + (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t) + (setq match-start (match-beginning 0) + match-end (match-end 0) + charset (match-string 1) + encoding (match-string 2) + start (match-beginning 3) + end (vm-marker (match-end 3))) + ;; don't change anything if we can't display the + ;; character set properly. + (if (not (vm-mime-charset-internally-displayable-p charset)) + nil + (delete-region end match-end) + (cond ((string-match "B" encoding) + (vm-mime-B-decode-region start end)) + ((string-match "Q" encoding) + (vm-mime-Q-decode-region start end)) + (t (vm-mime-error "unknown encoded word encoding, %s" + encoding))) + (vm-mime-charset-decode-region charset start end) + (delete-region match-start start)))))) + +(defun vm-decode-mime-encoded-words () + (let ((case-fold-search t) + (buffer-read-only nil) + charset encoding match-start match-end start end) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward vm-mime-encoded-word-regexp nil t) + (setq match-start (match-beginning 0) + match-end (match-end 0) + charset (match-string 1) + encoding (match-string 2) + start (match-beginning 3) + end (vm-marker (match-end 3))) + ;; don't change anything if we can't display the + ;; character set properly. + (if (not (vm-mime-charset-internally-displayable-p charset)) + nil + (delete-region end match-end) + (cond ((string-match "B" encoding) + (vm-mime-B-decode-region start end)) + ((string-match "Q" encoding) + (vm-mime-Q-decode-region start end)) + (t (vm-mime-error "unknown encoded word encoding, %s" + encoding))) + (vm-mime-charset-decode-region charset start end) + (delete-region match-start start)))))) + +(defun vm-decode-mime-encoded-words-maybe (string) + (if (and vm-display-using-mime + (string-match vm-mime-encoded-word-regexp string)) + (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words) + string )) + +(defun vm-mime-parse-content-header (string &optional sepchar) + (if (null string) + () + (let ((work-buffer nil)) + (save-excursion + (unwind-protect + (let ((list nil) + (nonspecials "^\"\\( \t\n\r\f") + start s char sp+sepchar) + (if sepchar + (setq nonspecials (concat nonspecials (list sepchar)) + sp+sepchar (concat "\t\f\n\r " (list sepchar)))) + (setq work-buffer (generate-new-buffer "*vm-work*")) + (buffer-disable-undo work-buffer) + (set-buffer work-buffer) + (insert string) + (goto-char (point-min)) + (skip-chars-forward "\t\f\n\r ") + (setq start (point)) + (while (not (eobp)) + (skip-chars-forward nonspecials) + (setq char (following-char)) + (cond ((looking-at "[ \t\n\r\f]") + (delete-char 1)) + ((= char ?\\) + (forward-char 1) + (if (not (eobp)) + (forward-char 1))) + ((and sepchar (= char sepchar)) + (setq s (buffer-substring start (point))) + (if (or (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (skip-chars-forward sp+sepchar) + (setq start (point))) + ((looking-at " \t\n\r\f") + (skip-chars-forward " \t\n\r\f")) + ((= char ?\") + (delete-char 1) + (cond ((= (char-after (point)) ?\") + (delete-char 1)) + ((re-search-forward "[^\\]\"" nil 0) + (delete-char -1)))) + ((= char ?\() + (let ((parens 1) + (pos (point))) + (forward-char 1) + (while (and (not (eobp)) (not (zerop parens))) + (re-search-forward "[()]" nil 0) + (cond ((or (eobp) + (= (char-after (- (point) 2)) ?\\))) + ((= (preceding-char) ?\() + (setq parens (1+ parens))) + (t + (setq parens (1- parens))))) + (delete-region pos (point)))))) + (setq s (buffer-substring start (point))) + (if (and (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (nreverse list)) + (and work-buffer (kill-buffer work-buffer))))))) + +(defun vm-mime-get-header-contents (header-name-regexp) + (let ((contents nil) + regexp) + (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) + (save-excursion + (let ((case-fold-search t)) + (if (and (re-search-forward regexp nil t) + (match-beginning 1) + (progn (goto-char (match-beginning 0)) + (vm-match-header))) + (vm-matched-header-contents) + nil ))))) + +(defun vm-mime-parse-entity (&optional m default-type default-encoding) + (let ((case-fold-search t) version type encoding id description + disposition boundary boundary-regexp start + multipart-list c-t c-t-e done p returnval) + (and m (vm-unsaved-message "Parsing MIME message...")) + (prog1 + (catch 'return-value + (save-excursion + (if m + (progn + (setq m (vm-real-message-of m)) + (set-buffer (vm-buffer-of m)))) + (save-excursion + (save-restriction + (if m + (progn + (setq version (vm-get-header-contents m "MIME-Version:") + version (car (vm-mime-parse-content-header version)) + type (vm-get-header-contents m "Content-Type:") + type (vm-mime-parse-content-header type ?\;) + encoding (or (vm-get-header-contents + m "Content-Transfer-Encoding:") + "7bit") + encoding (car (vm-mime-parse-content-header encoding)) + id (vm-get-header-contents m "Content-ID:") + id (car (vm-mime-parse-content-header id)) + description (vm-get-header-contents + m "Content-Description:") + description (and description + (if (string-match "^[ \t\n]$" + description) + nil + description)) + disposition (vm-get-header-contents + m "Content-Disposition:") + disposition (and disposition + (vm-mime-parse-content-header + disposition ?\;))) + (widen) + (narrow-to-region (vm-headers-of m) (vm-text-end-of m))) + (goto-char (point-min)) + (setq type (vm-mime-get-header-contents "Content-Type:") + type (or (vm-mime-parse-content-header type ?\;) + default-type) + encoding (or (vm-mime-get-header-contents + "Content-Transfer-Encoding:") + default-encoding) + encoding (car (vm-mime-parse-content-header encoding)) + id (vm-mime-get-header-contents "Content-ID:") + id (car (vm-mime-parse-content-header id)) + description (vm-mime-get-header-contents + "Content-Description:") + description (and description (if (string-match "^[ \t\n]+$" + description) + nil + description)) + disposition (vm-mime-get-header-contents + "Content-Disposition:") + disposition (and disposition + (vm-mime-parse-content-header + disposition ?\;)))) + (cond ((null m) t) + ((null version) + (throw 'return-value 'none)) + ((string= version "1.0") t) + (t (vm-mime-error "Unsupported MIME version: %s" version))) + (cond ((and m (null type)) + (throw 'return-value + (vector '("text/plain" "charset=us-ascii") + encoding id description disposition + (vm-headers-of m) + (vm-text-of m) + (vm-text-end-of m) + nil nil nil ))) + ((null type) + (goto-char (point-min)) + (or (re-search-forward "^\n\\|\n\\'" nil t) + (vm-mime-error "MIME part missing header/body separator line")) + (vector default-type encoding id description disposition + (vm-marker (point-min)) + (vm-marker (point)) + (vm-marker (point-max)) + nil nil nil )) + ((null (string-match "[^/ ]+/[^/ ]+" (car type))) + (vm-mime-error "Malformed MIME content type: %s" (car type))) + ((and (string-match "^multipart/\\|^message/" (car type)) + (null (string-match "^\\(7bit\\|8bit\\|binary\\)$" + encoding))) + (vm-mime-error "Opaque transfer encoding used with multipart or message type: %s, %s" (car type) encoding)) + ((and (string-match "^message/partial$" (car type)) + (null (string-match "^7bit$" encoding))) + (vm-mime-error "Non-7BIT transfer encoding used with message/partial message: %s" encoding)) + ((string-match "^multipart/digest" (car type)) + (setq c-t '("message/rfc822") + c-t-e "7bit")) + ((string-match "^multipart/" (car type)) + (setq c-t '("text/plain" "charset=us-ascii") + c-t-e "7bit")) ; below + ((string-match "^message/rfc822" (car type)) + (setq c-t '("text/plain" "charset=us-ascii") + c-t-e "7bit") + (goto-char (point-min)) + (or (re-search-forward "^\n\\|\n\\'" nil t) + (vm-mime-error "MIME part missing header/body separator line")) + (throw 'return-value + (vector type encoding id description disposition + (vm-marker (point-min)) + (vm-marker (point)) + (vm-marker (point-max)) + (list + (save-restriction + (narrow-to-region (point) (point-max)) + (vm-mime-parse-entity nil c-t c-t-e))) + nil ))) + (t + (goto-char (point-min)) + (or (re-search-forward "^\n\\|\n\\'" nil t) + (vm-mime-error "MIME part missing header/body separator line")) + (throw 'return-value + (vector type encoding id description disposition + (vm-marker (point-min)) + (vm-marker (point)) + (vm-marker (point-max)) + nil nil )))) + (setq p (cdr type) + boundary nil) + (while p + (if (string-match "^boundary=" (car p)) + (setq boundary (car (vm-parse (car p) "=\\(.+\\)")) + p nil) + (setq p (cdr p)))) + (or boundary + (vm-mime-error + "Boundary parameter missing in %s type specification" + (car type))) + (setq boundary-regexp (regexp-quote boundary) + boundary-regexp (concat "^--" boundary-regexp "\\(--\\)?\n")) + (goto-char (point-min)) + (setq start nil + multipart-list nil + done nil) + (while (and (not done) (re-search-forward boundary-regexp nil t)) + (cond ((null start) + (setq start (match-end 0))) + (t + (and (match-beginning 1) + (setq done t)) + (save-excursion + (save-restriction + (narrow-to-region start (1- (match-beginning 0))) + (setq start (match-end 0)) + (setq multipart-list + (cons (vm-mime-parse-entity-safe nil c-t c-t-e) + multipart-list))))))) + (if (not done) + (vm-mime-error "final %s boundary missing" boundary)) + (goto-char (point-min)) + (or (re-search-forward "^\n\\|\n\\'" nil t) + (vm-mime-error "MIME part missing header/body separator line")) + (vector type encoding id description disposition + (vm-marker (point-min)) + (vm-marker (point)) + (vm-marker (point-max)) + (nreverse multipart-list) + nil ))))) + (and m (vm-unsaved-message "Parsing MIME message... done")) + ))) + +(defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) + (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) + ;; don't let subpart parse errors make the whole parse fail. use default + ;; type if the parse fails. + (condition-case error-data + (vm-mime-parse-entity nil c-t c-t-e) + (vm-mime-error + (let ((header (if m + (vm-headers-of m) + (vm-marker (point-min)))) + (text (if m + (vm-text-of m) + (save-excursion + (re-search-forward "^\n\\|\n\\'" + nil 0) + (vm-marker (point))))) + (text-end (if m + (vm-text-end-of m) + (vm-marker (point-max))))) + (vector c-t + (vm-determine-proper-content-transfer-encoding text text-end) + nil + ;; cram the error message into the description slot + (car error-data) + ;; mark as an attachment to improve the chance that the user + ;; will see the description. + '("attachment") + header + text + text-end))))) + +(defun vm-mime-get-xxx-parameter (layout name param-list) + (let ((match-end (1+ (length name))) + (name-regexp (concat (regexp-quote name) "=")) + (case-fold-search t) + (done nil)) + (while (and param-list (not done)) + (if (and (string-match name-regexp (car param-list)) + (= (match-end 0) match-end)) + (setq done t) + (setq param-list (cdr param-list)))) + (and (car param-list) (car (vm-parse (car param-list) "=\\(.*\\)"))))) + +(defun vm-mime-get-parameter (layout name) + (vm-mime-get-xxx-parameter layout name (cdr (vm-mm-layout-type layout)))) + +(defun vm-mime-get-disposition-parameter (layout name) + (vm-mime-get-xxx-parameter layout name + (cdr (vm-mm-layout-disposition layout)))) + +(defun vm-mime-insert-mime-body (layout) + (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout)) + (vm-mm-layout-body-start layout) + (vm-mm-layout-body-end layout))) + +(defun vm-mime-insert-mime-headers (layout) + (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout)) + (vm-mm-layout-header-start layout) + (vm-mm-layout-body-start layout)) + (if (and (not (bobp)) (char-equal (char-after (1- (point))) ?\n)) + (delete-char -1))) + +(defun vm-make-presentation-copy (m) + (let ((mail-buffer (current-buffer)) + b mm + (real-m (vm-real-message-of m)) + (modified (buffer-modified-p))) + (cond ((or (null vm-presentation-buffer-handle) + (null (buffer-name vm-presentation-buffer-handle))) + (setq b (generate-new-buffer (concat (buffer-name) + " Presentation"))) + (save-excursion + (set-buffer b) + (if (fboundp 'buffer-disable-undo) + (buffer-disable-undo (current-buffer)) + ;; obfuscation to make the v19 compiler not whine + ;; about obsolete functions. + (let ((x 'buffer-flush-undo)) + (funcall x (current-buffer)))) + (setq mode-name "VM Presentation" + major-mode 'vm-presentation-mode + vm-message-pointer (list nil) + vm-mail-buffer mail-buffer + mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 + (vm-menu-support-possible-p) + (vm-menu-mode-menu)) + buffer-read-only t + mode-line-format vm-mode-line-format) + (cond ((vm-fsfemacs-19-p) + ;; need to do this outside the let because + ;; loading disp-table initializes + ;; standard-display-table. + (require 'disp-table) + (let* ((standard-display-table + (copy-sequence standard-display-table))) + (standard-display-european t) + (setq buffer-display-table standard-display-table)))) + (if vm-frame-per-folder + (vm-set-hooks-for-frame-deletion)) + (use-local-map vm-mode-map) + (and (vm-toolbar-support-possible-p) vm-use-toolbar + (vm-toolbar-install-toolbar)) + (and (vm-menu-support-possible-p) + (vm-menu-install-menus))) + (setq vm-presentation-buffer-handle b))) + ;; do this (widen) outside save-restricton intentionally. since + ;; we're using the presentation buffer, make the folder + ;; buffer unpretty so maybe the user gets the idea. + ;;(widen) + ;; widening isn't enough. users just complain that "I'm + ;; looking at the wrong message." Curse their miserable hides. + ;; bury the buffer so they'll have a tough time finding it. + (bury-buffer (current-buffer)) + (setq b vm-presentation-buffer-handle + vm-presentation-buffer vm-presentation-buffer-handle + vm-mime-decoded nil) + (save-excursion + (set-buffer (vm-buffer-of real-m)) + (save-restriction + (widen) + ;; must reference this now so that headers will be in + ;; their final position before the message is copied. + ;; otherwise the vheader offset computed below will be + ;; wrong. + (vm-vheaders-of real-m) + (set-buffer b) + (widen) + (let ((buffer-read-only nil) + (modified (buffer-modified-p))) + (unwind-protect + (progn + (erase-buffer) + (insert-buffer-substring (vm-buffer-of real-m) + (vm-start-of real-m) + (vm-end-of real-m))) + (set-buffer-modified-p modified))) + (setq mm (copy-sequence m)) + (vm-set-location-data-of mm (vm-copy (vm-location-data-of m))) + (set-marker (vm-start-of mm) (point-min)) + (set-marker (vm-headers-of mm) (+ (vm-start-of mm) + (- (vm-headers-of real-m) + (vm-start-of real-m)))) + (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm) + (- (vm-vheaders-of real-m) + (vm-start-of real-m)))) + (set-marker (vm-text-of mm) (+ (vm-start-of mm) + (- (vm-text-of real-m) + (vm-start-of real-m)))) + (set-marker (vm-text-end-of mm) (+ (vm-start-of mm) + (- (vm-text-end-of real-m) + (vm-start-of real-m)))) + (set-marker (vm-end-of mm) (+ (vm-start-of mm) + (- (vm-end-of real-m) + (vm-start-of real-m)))) + (setcar vm-message-pointer mm))))) + +(fset 'vm-presentation-mode 'vm-mode) +(put 'vm-presentation-mode 'mode-class 'special) + +(defun vm-determine-proper-charset (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (catch 'done + (goto-char (point-min)) + (and (re-search-forward "[^\000-\177]" nil t) + (throw 'done (or vm-mime-8bit-composition-charset "iso-8859-1"))) + (throw 'done "us-ascii"))))) + +(defun vm-determine-proper-content-transfer-encoding (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (catch 'done + (goto-char (point-min)) + (and (re-search-forward "[\000\015]" nil t) + (throw 'done "binary")) + + (let ((toolong nil) bol) + (goto-char (point-min)) + (setq bol (point)) + (while (and (not (eobp)) (not toolong)) + (forward-line) + (setq toolong (> (- (point) bol) 998) + bol (point))) + (and toolong (throw 'done "binary"))) + + (goto-char (point-min)) + (and (re-search-forward "[\200-\377]" nil t) + (throw 'done "8bit")) + + "7bit")))) + +(defun vm-mime-types-match (type type/subtype) + (let ((case-fold-search t)) + (cond ((string-match "/" type) + (if (and (string-match (regexp-quote type) type/subtype) + (equal 0 (match-beginning 0)) + (equal (length type/subtype) (match-end 0))) + t + nil )) + ((and (string-match (regexp-quote type) type/subtype) + (equal 0 (match-beginning 0)) + (equal (save-match-data + (string-match "/" type/subtype (match-end 0))) + (match-end 0))))))) + +(defvar native-sound-only-on-console) + +(defun vm-mime-can-display-internal (layout) + (let ((type (car (vm-mm-layout-type layout)))) + (cond ((vm-mime-types-match "image/jpeg" type) + (and (vm-xemacs-p) + (featurep 'jpeg) + (eq (device-type) 'x))) + ((vm-mime-types-match "image/gif" type) + (and (vm-xemacs-p) + (featurep 'gif) + (eq (device-type) 'x))) + ((vm-mime-types-match "image/png" type) + (and (vm-xemacs-p) + (featurep 'png) + (eq (device-type) 'x))) + ((vm-mime-types-match "image/tiff" type) + (and (vm-xemacs-p) + (featurep 'tiff) + (eq (device-type) 'x))) + ((vm-mime-types-match "audio/basic" type) + (and (vm-xemacs-p) + (or (featurep 'native-sound) + (featurep 'nas-sound)) + (or (device-sound-enabled-p) + (and (featurep 'native-sound) + (not native-sound-only-on-console) + (eq (device-type) 'x))))) + ((vm-mime-types-match "multipart" type) t) + ((vm-mime-types-match "message/external-body" type) nil) + ((vm-mime-types-match "message" type) t) + ((or (vm-mime-types-match "text/plain" type) + (vm-mime-types-match "text/enriched" type)) + (let ((charset (or (vm-mime-get-parameter layout "charset") + "us-ascii"))) + (vm-mime-charset-internally-displayable-p charset))) + ((vm-mime-types-match "text/html" type) + (condition-case () + (progn (require 'w3) + (fboundp 'w3-region)) + (error nil))) + (t nil)))) + +(defun vm-mime-can-convert (type) + (let ((alist vm-mime-type-converter-alist) + ;; fake layout. make it the wrong length so an error will + ;; be signaled if vm-mime-can-display-internal ever asks + ;; for one of the other fields + (fake-layout (make-vector 1 (list nil))) + (done nil)) + (while (and alist (not done)) + (cond ((and (vm-mime-types-match (car (car alist)) type) + (or (progn + (setcar (aref fake-layout 0) (nth 1 (car alist))) + (vm-mime-can-display-internal fake-layout)) + (vm-mime-find-external-viewer (nth 1 (car alist))))) + (setq done t)) + (t (setq alist (cdr alist))))) + (and alist (car alist)))) + +(defun vm-mime-convert-undisplayable-layout (layout) + (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout))))) + (vm-unsaved-message "Converting %s to %s..." + (car (vm-mm-layout-type layout)) + (nth 1 ooo)) + (save-excursion + (set-buffer (generate-new-buffer " *mime object*")) + (setq vm-message-garbage-alist + (cons (cons (current-buffer) 'kill-buffer) + vm-message-garbage-alist)) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout (point-min) (point-max)) + (call-process-region (point-min) (point-max) shell-file-name + t t nil shell-command-switch (nth 2 ooo)) + (goto-char (point-min)) + (insert "Content-Type: " (nth 1 ooo) "\n") + (insert "Content-Transfer-Encoding: binary\n\n") + (set-buffer-modified-p nil) + (vm-unsaved-message "Converting %s to %s... done" + (car (vm-mm-layout-type layout)) + (nth 1 ooo)) + (vector (list (nth 1 ooo)) + "binary" + (vm-mm-layout-id layout) + (vm-mm-layout-description layout) + (vm-mm-layout-disposition layout) + (vm-marker (point-min)) + (vm-marker (point)) + (vm-marker (point-max)) + nil + nil )))) + +(defun vm-mime-should-display-button (layout dont-honor-content-disposition) + (if (and vm-honor-mime-content-disposition + (not dont-honor-content-disposition) + (vm-mm-layout-disposition layout)) + (let ((case-fold-search t)) + (string-match "^attachment$" (car (vm-mm-layout-disposition layout)))) + (let ((i-list vm-auto-displayed-mime-content-types) + (type (car (vm-mm-layout-type layout))) + (matched nil)) + (if (eq i-list t) + nil + (while (and i-list (not matched)) + (if (vm-mime-types-match (car i-list) type) + (setq matched t) + (setq i-list (cdr i-list)))) + (not matched) )))) + +(defun vm-mime-should-display-internal (layout dont-honor-content-disposition) + (if (and vm-honor-mime-content-disposition + (not dont-honor-content-disposition) + (vm-mm-layout-disposition layout)) + (let ((case-fold-search t)) + (string-match "^inline$" (car (vm-mm-layout-disposition layout)))) + (let ((i-list vm-mime-internal-content-types) + (type (car (vm-mm-layout-type layout))) + (matched nil)) + (if (eq i-list t) + t + (while (and i-list (not matched)) + (if (vm-mime-types-match (car i-list) type) + (setq matched t) + (setq i-list (cdr i-list)))) + matched )))) + +(defun vm-mime-find-external-viewer (type) + (let ((e-alist vm-mime-external-content-types-alist) + (matched nil)) + (while (and e-alist (not matched)) + (if (and (vm-mime-types-match (car (car e-alist)) type) + (cdr (car e-alist))) + (setq matched (cdr (car e-alist))) + (setq e-alist (cdr e-alist)))) + matched )) +(fset 'vm-mime-should-display-external 'vm-mime-find-external-viewer) + +(defun vm-mime-delete-button-maybe (extent) + (let ((buffer-read-only)) + ;; if displayed MIME object should replace the button + ;; remove the button now. + (cond ((vm-extent-property extent 'vm-mime-disposable) + (delete-region (vm-extent-start-position extent) + (vm-extent-end-position extent)) + (vm-detach-extent extent))))) + +(defun vm-decode-mime-message () + "Decode the MIME objects in the current message. + +The first time this command is run on a message, decoding is done. +The second time, buttons for all the objects are displayed instead. +The third time, the raw, undecoded data is displayed. + +If decoding, the decoded objects might be displayed immediately, or +buttons might be displayed that you need to activate to view the +object. See the documentation for the variables + + vm-auto-displayed-mime-content-types + vm-mime-internal-content-types + vm-mime-external-content-types-alist + +to see how to control whether you see buttons or objects. + +If the variable vm-mime-display-function is set, then its value +is called as a function with no arguments, and none of the +actions mentioned in the preceding paragraphs are done. At the +time of the call, the current buffer will be the presentation +buffer for the folder and a copy of the current message will be +in the buffer. The function is expected to make the message +`MIME presentable' to the user in whatever manner it sees fit." + (interactive) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) + (vm-error-if-folder-empty) + (if (and (not vm-display-using-mime) + (null vm-mime-display-function)) + (error "MIME display disabled, set vm-display-using-mime non-nil to enable.")) + (if vm-mime-display-function + (progn + (vm-make-presentation-copy (car vm-message-pointer)) + (set-buffer vm-presentation-buffer) + (funcall vm-mime-display-function)) + (if vm-mime-decoded + (if (eq vm-mime-decoded 'decoded) + (let ((vm-preview-read-messages nil) + (vm-auto-decode-mime-messages t) + (vm-honor-mime-content-disposition nil) + (vm-auto-displayed-mime-content-types '("multipart"))) + (setq vm-mime-decoded nil) + (intern (buffer-name) vm-buffers-needing-display-update) + (save-excursion + (vm-preview-current-message)) + (setq vm-mime-decoded 'buttons)) + (let ((vm-preview-read-messages nil) + (vm-auto-decode-mime-messages nil)) + (intern (buffer-name) vm-buffers-needing-display-update) + (vm-preview-current-message))) + (let ((layout (vm-mm-layout (car vm-message-pointer))) + (m (car vm-message-pointer))) + (vm-unsaved-message "Decoding MIME message...") + (cond ((stringp layout) + (error "Invalid MIME message: %s" layout))) + (if (vm-mime-plain-message-p m) + (error "Message needs no decoding.")) + (or vm-presentation-buffer + ;; maybe user killed it + (error "No presentation buffer.")) + (set-buffer vm-presentation-buffer) + (setq m (car vm-message-pointer)) + (vm-save-restriction + (widen) + (goto-char (vm-text-of m)) + (let ((buffer-read-only nil) + (modified (buffer-modified-p))) + (unwind-protect + (save-excursion + (and (not (eq (vm-mm-encoded-header m) 'none)) + (vm-decode-mime-message-headers m)) + (if (vectorp layout) + (progn + (vm-decode-mime-layout layout) + (delete-region (point) (point-max))))) + (set-buffer-modified-p modified)))) + (save-excursion (set-buffer vm-mail-buffer) + (setq vm-mime-decoded 'decoded)) + (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) + (vm-update-summary-and-mode-line) + (vm-unsaved-message "Decoding MIME message... done")))) + (vm-display nil nil '(vm-decode-mime-message) + '(vm-decode-mime-message reading-message))) + +(defun vm-decode-mime-layout (layout &optional dont-honor-c-d) + (let ((modified (buffer-modified-p)) type type-no-subtype (extent nil)) + (unwind-protect + (progn + (if (not (vectorp layout)) + (progn + (setq extent layout + layout (vm-extent-property extent 'vm-mime-layout)) + (goto-char (vm-extent-start-position extent)))) + (setq type (downcase (car (vm-mm-layout-type layout))) + type-no-subtype (car (vm-parse type "\\([^/]+\\)"))) + (cond ((and (vm-mime-should-display-button layout dont-honor-c-d) + (or (condition-case nil + (funcall (intern + (concat "vm-mime-display-button-" + type)) + layout) + (void-function nil)) + (condition-case nil + (funcall (intern + (concat "vm-mime-display-button-" + type-no-subtype)) + layout) + (void-function nil))))) + ((and (vm-mime-should-display-internal layout dont-honor-c-d) + (condition-case nil + (funcall (intern + (concat "vm-mime-display-internal-" + type)) + layout) + (void-function nil)))) + ((vm-mime-types-match "multipart" type) + (or (condition-case nil + (funcall (intern + (concat "vm-mime-display-internal-" + type)) + layout) + (void-function nil)) + (vm-mime-display-internal-multipart/mixed layout))) + ((and (vm-mime-should-display-external type) + (vm-mime-display-external-generic layout)) + (and extent (vm-set-extent-property + extent 'vm-mime-disposable nil))) + ((vm-mime-can-convert type) + (vm-decode-mime-layout + (vm-mime-convert-undisplayable-layout layout))) + ((and (or (vm-mime-types-match "message" type) + (vm-mime-types-match "text" type)) + ;; display unmatched message and text types as + ;; text/plain. + (vm-mime-display-internal-text/plain layout))) + (t (vm-mime-display-internal-application/octet-stream + (or extent layout)))) + (and extent (vm-mime-delete-button-maybe extent))) + (set-buffer-modified-p modified))) + t ) + +(defun vm-mime-display-button-text (layout) + (vm-mime-display-button-xxxx layout t)) + +(defun vm-mime-display-internal-text/html (layout) + (let ((buffer-read-only nil) + (work-buffer nil)) + (vm-unsaved-message "Inlining text/html, be patient...") + ;; w3-region is not as tame as we would like. + ;; make sure the yoke is firmly attached. + (unwind-protect + (progn + (save-excursion + (set-buffer (setq work-buffer + (generate-new-buffer " *workbuf*"))) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout (point-min) (point-max)) + (save-excursion + (save-window-excursion + (w3-region (point-min) (point-max))))) + (insert-buffer-substring work-buffer)) + (and work-buffer (kill-buffer work-buffer))) + (vm-unsaved-message "Inlining text/html... done") + t )) + +(defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) + (let ((start (point)) end + (buffer-read-only nil) + (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) + (if (not (vm-mime-charset-internally-displayable-p charset)) + nil + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + (vm-mime-charset-decode-region charset start end) + (or ignore-urls (vm-energize-urls-in-message-region start end)) + t ))) + +(defun vm-mime-display-internal-text/enriched (layout) + (require 'enriched) + (let ((start (point)) end + (buffer-read-only nil) + (enriched-verbose t)) + (vm-unsaved-message "Decoding text/enriched, be patient...") + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + ;; enriched-decode expects a couple of headers at the top of + ;; the region and will remove anything that looks like a + ;; header. Put a header section here for it to eat so it + ;; won't eat message text instead. + (goto-char start) + (insert "Comment: You should not see this header\n\n") + (enriched-decode start end) + (vm-energize-urls-in-message-region start end) + (goto-char end) + (vm-unsaved-message "Decoding text/enriched... done") + t )) + +(defun vm-mime-display-external-generic (layout) + (let ((program-list (vm-mime-find-external-viewer + (car (vm-mm-layout-type layout)))) + (process (nth 0 (vm-mm-layout-cache layout))) + (tempfile (nth 1 (vm-mm-layout-cache layout))) + (buffer-read-only nil) + (start (point)) + end) + (if (and (processp process) (eq (process-status process) 'run)) + nil + (cond ((or (null tempfile) (null (file-exists-p tempfile))) + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + (setq tempfile (vm-make-tempfile-name)) + ;; Tell DOS/Windows NT whether the file is binary + (setq buffer-file-type (not (vm-mime-text-type-p layout))) + (write-region start end tempfile nil 0) + (delete-region start end) + (save-excursion + (vm-select-folder-buffer) + (setq vm-folder-garbage-alist + (cons (cons tempfile 'delete-file) + vm-folder-garbage-alist))))) + (vm-unsaved-message "Launching %s..." (mapconcat 'identity + program-list + " ")) + (setq process + (apply 'start-process + (format "view %25s" (vm-mime-layout-description layout)) + nil (append program-list (list tempfile)))) + (process-kill-without-query process t) + (vm-unsaved-message "Launching %s... done" (mapconcat 'identity + program-list + " ")) + (save-excursion + (vm-select-folder-buffer) + (setq vm-message-garbage-alist + (cons (cons process 'delete-process) + vm-message-garbage-alist))) + (vm-set-mm-layout-cache layout (list process tempfile)))) + t ) + +(defun vm-mime-display-internal-application/octet-stream (layout) + (if (vectorp layout) + (let ((buffer-read-only nil) + (description (vm-mm-layout-description layout))) + (vm-mime-insert-button + (format "%-35s [%s to save to a file]" + (vm-mime-layout-description layout) + (if (vm-mouse-support-possible-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (vm-mime-display-internal-application/octet-stream layout)))) + layout nil)) + (goto-char (vm-extent-start-position layout)) + (setq layout (vm-extent-property layout 'vm-mime-layout)) + ;; support old "name" paramater for application/octet-stream + ;; but don't override the "filename" parameter extracted from + ;; Content-Disposition, if any. + (let ((default-filename + (if (vm-mime-get-disposition-parameter layout "filename") + nil + (vm-mime-get-parameter layout "name")))) + (vm-mime-send-body-to-file layout default-filename))) + t ) +(fset 'vm-mime-display-button-application + 'vm-mime-display-internal-application/octet-stream) + +(defun vm-mime-display-button-image (layout) + (vm-mime-display-button-xxxx layout t)) + +(defun vm-mime-display-button-audio (layout) + (vm-mime-display-button-xxxx layout nil)) + +(defun vm-mime-display-button-video (layout) + (vm-mime-display-button-xxxx layout t)) + +(defun vm-mime-display-button-message (layout) + (vm-mime-display-button-xxxx layout t)) + +(defun vm-mime-display-button-multipart (layout) + (vm-mime-display-button-xxxx layout t)) + +(defun vm-mime-display-internal-multipart/mixed (layout) + (let ((part-list (vm-mm-layout-parts layout))) + (while part-list + (vm-decode-mime-layout (car part-list)) + (setq part-list (cdr part-list))) + t )) + +(defun vm-mime-display-internal-multipart/alternative (layout) + (let (best-layout) + (cond ((eq vm-mime-alternative-select-method 'best) + (let ((done nil) + (best nil) + part-list type) + (setq part-list (vm-mm-layout-parts layout) + part-list (nreverse (copy-sequence part-list))) + (while (and part-list (not done)) + (setq type (car (vm-mm-layout-type (car part-list)))) + (if (or (vm-mime-can-display-internal (car part-list)) + (vm-mime-find-external-viewer type)) + (setq best (car part-list) + done t) + (setq part-list (cdr part-list)))) + (setq best-layout (or best (car (vm-mm-layout-parts layout)))))) + ((eq vm-mime-alternative-select-method 'best-internal) + (let ((done nil) + (best nil) + (second-best nil) + part-list type) + (setq part-list (vm-mm-layout-parts layout) + part-list (nreverse (copy-sequence part-list))) + (while (and part-list (not done)) + (setq type (car (vm-mm-layout-type (car part-list)))) + (cond ((vm-mime-can-display-internal (car part-list)) + (setq best (car part-list) + done t)) + ((and (null second-best) + (vm-mime-find-external-viewer type)) + (setq second-best (car part-list)))) + (setq part-list (cdr part-list))) + (setq best-layout (or best second-best + (car (vm-mm-layout-parts layout))))))) + (vm-decode-mime-layout best-layout))) + +(defun vm-mime-display-button-multipart/parallel (layout) + (vm-mime-insert-button + (format "%-35s [%s to display in parallel]" + (vm-mime-layout-description layout) + (if (vm-mouse-support-possible-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (let ((vm-auto-displayed-mime-content-types t)) + (vm-decode-mime-layout layout t))))) + layout t)) + +(fset 'vm-mime-display-internal-multipart/parallel + 'vm-mime-display-internal-multipart/mixed) + +(defun vm-mime-display-internal-multipart/digest (layout) + (if (vectorp layout) + (let ((buffer-read-only nil)) + (vm-mime-insert-button + (format "%-35s [%s to display]" + (vm-mime-layout-description layout) + (if (vm-mouse-support-possible-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (vm-mime-display-internal-multipart/digest layout)))) + layout nil)) + (goto-char (vm-extent-start-position layout)) + (setq layout (vm-extent-property layout 'vm-mime-layout)) + (set-buffer (generate-new-buffer (format "digest from %s/%s" + (buffer-name vm-mail-buffer) + (vm-number-of + (car vm-message-pointer))))) + (setq vm-folder-type vm-default-folder-type) + (vm-mime-burst-layout layout nil) + (vm-save-buffer-excursion + (vm-goto-new-folder-frame-maybe 'folder) + (vm-mode)) + ;; temp buffer, don't offer to save it. + (setq buffer-offer-save nil) + (vm-display nil nil (list this-command) '(vm-mode startup))) + t ) +(fset 'vm-mime-display-button-multipart/digest + 'vm-mime-display-internal-multipart/digest) + +(defun vm-mime-display-internal-message/rfc822 (layout) + (if (vectorp layout) + (let ((buffer-read-only nil)) + (vm-mime-insert-button + (format "%-35s [%s to display]" + (vm-mime-layout-description layout) + (if (vm-mouse-support-possible-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (vm-mime-display-internal-message/rfc822 layout)))) + layout nil)) + (goto-char (vm-extent-start-position layout)) + (setq layout (vm-extent-property layout 'vm-mime-layout)) + (set-buffer (generate-new-buffer + (format "message from %s/%s" + (buffer-name vm-mail-buffer) + (vm-number-of + (car vm-message-pointer))))) + (setq vm-folder-type vm-default-folder-type) + (vm-mime-burst-layout layout nil) + (set-buffer-modified-p nil) + (vm-save-buffer-excursion + (vm-goto-new-folder-frame-maybe 'folder) + (vm-mode)) + ;; temp buffer, don't offer to save it. + (setq buffer-offer-save nil) + (vm-display (or vm-presentation-buffer (current-buffer)) t + (list this-command) '(vm-mode startup))) + t ) +(fset 'vm-mime-display-button-message/rfc822 + 'vm-mime-display-internal-message/rfc822) + +(defun vm-mime-display-internal-message/partial (layout) + (if (vectorp layout) + (let ((buffer-read-only nil) + (number (vm-mime-get-parameter layout "number")) + (total (vm-mime-get-parameter layout "total"))) + (vm-mime-insert-button + (format "%-35s [%s to attempt assembly]" + (concat (vm-mime-layout-description layout) + (and number (concat ", part " number)) + (and number total (concat " of " total))) + (if (vm-mouse-support-possible-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (vm-mime-display-internal-message/partial layout)))) + layout nil)) + (vm-unsaved-message "Assembling message...") + (let ((parts nil) + (missing nil) + (work-buffer nil) + extent id o number total m i prev part-header-pos + p-id p-number p-total p-list) + (setq extent layout + layout (vm-extent-property extent 'vm-mime-layout) + id (vm-mime-get-parameter layout "id")) + (if (null id) + (vm-mime-error + "message/partial message missing id parameter")) + (save-excursion + (set-buffer (marker-buffer (vm-mm-layout-body-start layout))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (and (search-forward id nil t) + (setq m (vm-message-at-point))) + (setq o (vm-mm-layout m)) + (if (not (vectorp o)) + nil + (setq p-list (vm-mime-find-message/partials o id)) + (while p-list + (setq p-id (vm-mime-get-parameter (car p-list) "id")) + (setq p-total (vm-mime-get-parameter (car p-list) "total")) + (if (null p-total) + nil + (setq p-total (string-to-int p-total)) + (if (< p-total 1) + (vm-mime-error "message/partial specified part total < 0, %d" p-total)) + (if total + (if (not (= total p-total)) + (vm-mime-error "message/partial speificed total differs between parts, (%d != %d)" p-total total)) + (setq total p-total))) + (setq p-number (vm-mime-get-parameter (car p-list) "number")) + (if (null p-number) + (vm-mime-error + "message/partial message missing number parameter")) + (setq p-number (string-to-int p-number)) + (if (< p-number 1) + (vm-mime-error "message/partial part number < 0, %d" + p-number)) + (if (and total (> p-number total)) + (vm-mime-error "message/partial part number greater than expected number of parts, (%d > %d)" p-number total)) + (setq parts (cons (list p-number (car p-list)) parts) + p-list (cdr p-list)))) + (goto-char (vm-mm-layout-body-end o)))))) + (if (null total) + (vm-mime-error "total number of parts not specified in any message/partial part")) + (setq parts (sort parts + (function + (lambda (p q) + (< (car p) + (car q)))))) + (setq i 0 + p-list parts) + (while p-list + (cond ((< i (car (car p-list))) + (vm-increment i) + (cond ((not (= i (car (car p-list)))) + (setq missing (cons i missing))) + (t (setq prev p-list + p-list (cdr p-list))))) + (t + ;; remove duplicate part + (setcdr prev (cdr p-list)) + (setq p-list (cdr p-list))))) + (while (< i total) + (vm-increment i) + (setq missing (cons i missing))) + (if missing + (vm-mime-error "part%s %s%s missing" + (if (cdr missing) "s" "") + (mapconcat + (function identity) + (nreverse (mapcar 'int-to-string + (or (cdr missing) missing))) + ", ") + (if (cdr missing) + (concat " and " (car missing)) + ""))) + (set-buffer (generate-new-buffer "assembled message")) + (setq vm-folder-type vm-default-folder-type) + (vm-mime-insert-mime-headers (car (cdr (car parts)))) + (goto-char (point-min)) + (vm-reorder-message-headers + nil nil +"\\(Encrypted\\|Content-\\|MIME-Version\\|Message-ID\\|Subject\\|X-VM-\\|Status\\)") + (goto-char (point-max)) + (setq part-header-pos (point)) + (while parts + (vm-mime-insert-mime-body (car (cdr (car parts)))) + (setq parts (cdr parts))) + (goto-char part-header-pos) + (vm-reorder-message-headers + nil '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") nil) + (vm-munge-message-separators vm-folder-type (point-min) (point-max)) + (goto-char (point-min)) + (insert (vm-leading-message-separator)) + (goto-char (point-max)) + (insert (vm-trailing-message-separator)) + (set-buffer-modified-p nil) + (vm-unsaved-message "Assembling message... done") + (vm-save-buffer-excursion + (vm-goto-new-folder-frame-maybe 'folder) + (vm-mode)) + ;; temp buffer, don't offer to save it. + (setq buffer-offer-save nil) + (vm-display (or vm-presentation-buffer (current-buffer)) t + (list this-command) '(vm-mode startup))) + t )) +(fset 'vm-mime-display-button-message/partial + 'vm-mime-display-internal-message/partial) + +(defun vm-mime-display-internal-image-xxxx (layout feature name) + (if (and (vm-xemacs-p) + (featurep feature) + (eq (device-type) 'x)) + (let ((start (point)) end tempfile g e + (buffer-read-only nil)) + (if (vm-mm-layout-cache layout) + (setq g (vm-mm-layout-cache layout)) + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + (setq tempfile (vm-make-tempfile-name)) + (write-region start end tempfile nil 0) + (vm-unsaved-message "Creating %s glyph..." name) + (setq g (make-glyph + (list (vector feature ':file tempfile) + (vector 'string + ':data + (format "[Unknown %s image encoding]\n" + name))))) + (vm-unsaved-message "") + (vm-set-mm-layout-cache layout g) + (save-excursion + (vm-select-folder-buffer) + (setq vm-folder-garbage-alist + (cons (cons tempfile 'delete-file) + vm-folder-garbage-alist))) + (delete-region start end)) + (if (not (bolp)) + (insert-char ?\n 2) + (insert-char ?\n 1)) + (setq e (vm-make-extent (1- (point)) (point))) + (vm-set-extent-property e 'begin-glyph g) + t ))) + +(defun vm-mime-display-internal-image/gif (layout) + (vm-mime-display-internal-image-xxxx layout 'gif "GIF")) + +(defun vm-mime-display-internal-image/jpeg (layout) + (vm-mime-display-internal-image-xxxx layout 'jpeg "JPEG")) + +(defun vm-mime-display-internal-image/png (layout) + (vm-mime-display-internal-image-xxxx layout 'png "PNG")) + +(defun vm-mime-display-internal-image/tiff (layout) + (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF")) + +(defun vm-mime-display-internal-audio/basic (layout) + (if (and (vm-xemacs-p) + (or (featurep 'native-sound) + (featurep 'nas-sound)) + (or (device-sound-enabled-p) + (and (featurep 'native-sound) + (not native-sound-only-on-console) + (eq (device-type) 'x)))) + (let ((start (point)) end tempfile + (buffer-read-only nil)) + (if (vm-mm-layout-cache layout) + (setq tempfile (vm-mm-layout-cache layout)) + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + (setq tempfile (vm-make-tempfile-name)) + (write-region start end tempfile nil 0) + (vm-set-mm-layout-cache layout tempfile) + (save-excursion + (vm-select-folder-buffer) + (setq vm-folder-garbage-alist + (cons (cons tempfile 'delete-file) + vm-folder-garbage-alist))) + (delete-region start end)) + (start-itimer "audioplayer" + (list 'lambda nil (list 'play-sound-file tempfile)) + 1) + t ) + nil )) + +(defun vm-mime-display-button-xxxx (layout disposable) + (let ((description (vm-mime-layout-description layout))) + (vm-mime-insert-button + (format "%-35s [%s to display]" + description + (if (vm-mouse-support-possible-p) "Click mouse-2" "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (let ((vm-auto-displayed-mime-content-types t)) + (vm-decode-mime-layout layout t))))) + layout disposable) + t )) + +(defun vm-mime-run-display-function-at-point (&optional function) + (interactive) + ;; save excursion to keep point from moving. its motion would + ;; drag window point along, to a place arbitrarily far from + ;; where it was when the user triggered the button. + (save-excursion + (cond ((vm-fsfemacs-19-p) + (let (o-list o (found nil)) + (setq o-list (overlays-at (point))) + (while (and o-list (not found)) + (cond ((overlay-get (car o-list) 'vm-mime-layout) + (setq found t) + (funcall (or function (overlay-get (car o-list) + 'vm-mime-function)) + (car o-list)))) + (setq o-list (cdr o-list))))) + ((vm-xemacs-p) + (let ((e (extent-at (point) nil 'vm-mime-layout))) + (funcall (or function (extent-property e 'vm-mime-function)) + e)))))) + +;; for the karking compiler +(defvar vm-menu-mime-dispose-menu) + +(defun vm-mime-insert-button (caption action layout disposable) + (let ((start (point)) e + (keymap (make-sparse-keymap)) + (buffer-read-only nil)) + (if (fboundp 'set-keymap-parents) + (set-keymap-parents keymap (list (current-local-map))) + (setq keymap (nconc keymap (current-local-map)))) + (define-key keymap "\r" 'vm-mime-run-display-function-at-point) + (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3) + (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu)) + (if (not (bolp)) + (insert "\n")) + (insert caption "\n") + ;; we MUST have the five arg make-overlay. overlays must + ;; advance when text is inserted at their start position or + ;; inline text and graphics will seep into the button + ;; overlay and then be removed when the button is removed. + (if (fboundp 'make-overlay) + (setq e (make-overlay start (point) nil t nil)) + (setq e (make-extent start (point))) + (set-extent-property e 'start-open t) + (set-extent-property e 'end-open t)) + ;; for emacs + (vm-set-extent-property e 'mouse-face 'highlight) + (vm-set-extent-property e 'local-map keymap) + ;; for xemacs + (vm-set-extent-property e 'highlight t) + (vm-set-extent-property e 'keymap keymap) + (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help) + ;; for all + (vm-set-extent-property e 'vm-mime-disposable disposable) + (vm-set-extent-property e 'face vm-mime-button-face) + (vm-set-extent-property e 'vm-mime-layout layout) + (vm-set-extent-property e 'vm-mime-function action))) + +(defun vm-mime-send-body-to-file (layout &optional default-filename) + (if (not (vectorp layout)) + (setq layout (vm-extent-property layout 'vm-mime-layout))) + (or default-filename + (setq default-filename + (vm-mime-get-disposition-parameter layout "filename"))) + (and default-filename + (setq default-filename (file-name-nondirectory default-filename))) + (let ((work-buffer nil) + ;; evade the XEmacs dialox box, yeccch. + (should-use-dialog-box nil) + file) + (setq file + (read-file-name + (if default-filename + (format "Write MIME body to file (default %s): " + default-filename) + "Write MIME body to file: ") + vm-mime-attachment-save-directory default-filename) + file (expand-file-name file vm-mime-attachment-save-directory)) + (save-excursion + (unwind-protect + (progn + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (set-buffer work-buffer) + ;; Tell DOS/Windows NT whether the file is binary + (setq buffer-file-type (not (vm-mime-text-type-p layout))) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout (point-min) (point-max)) + (or (not (file-exists-p file)) + (y-or-n-p "File exists, overwrite? ") + (error "Aborted")) + (write-region (point-min) (point-max) file nil nil)) + (and work-buffer (kill-buffer work-buffer)))))) + +(defun vm-mime-pipe-body-to-command (layout &optional discard-output) + (if (not (vectorp layout)) + (setq layout (vm-extent-property layout 'vm-mime-layout))) + (let ((command-line (read-string "Pipe to command: ")) + (output-buffer (if discard-output + 0 + (get-buffer-create "*Shell Command Output*"))) + (work-buffer nil)) + (save-excursion + (if (bufferp output-buffer) + (progn + (set-buffer output-buffer) + (erase-buffer))) + (unwind-protect + (progn + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (set-buffer work-buffer) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout (point-min) (point-max)) + (let ((pop-up-windows (and pop-up-windows + (eq vm-mutable-windows t))) + ;; Tell DOS/Windows NT whether the input is binary + (binary-process-input (not (vm-mime-text-type-p layout)))) + (call-process-region (point-min) (point-max) + (or shell-file-name "sh") + nil output-buffer nil + shell-command-switch command-line))) + (and work-buffer (kill-buffer work-buffer))) + (if (bufferp output-buffer) + (progn + (set-buffer output-buffer) + (if (not (zerop (buffer-size))) + (vm-display output-buffer t (list this-command) + '(vm-pipe-message-to-command)) + (vm-display nil nil (list this-command) + '(vm-pipe-message-to-command))))))) + t ) + +(defun vm-mime-pipe-body-to-command-discard-output (layout) + (vm-mime-pipe-body-to-command layout t)) + +(defun vm-mime-scrub-description (string) + (let ((work-buffer nil)) + (save-excursion + (unwind-protect + (progn + (setq work-buffer (generate-new-buffer " *vm-work*")) + (buffer-disable-undo work-buffer) + (set-buffer work-buffer) + (insert string) + (while (re-search-forward "[ \t\n]+" nil t) + (replace-match " ")) + (buffer-string)) + (and work-buffer (kill-buffer work-buffer)))))) + +(defun vm-mime-layout-description (layout) + (if (vm-mm-layout-description layout) + (vm-mime-scrub-description (vm-mm-layout-description layout)) + (let ((type (car (vm-mm-layout-type layout))) + name) + (cond ((vm-mime-types-match "multipart/digest" type) + (let ((n (length (vm-mm-layout-parts layout)))) + (format "digest (%d message%s)" n (if (= n 1) "" "s")))) + ((vm-mime-types-match "multipart/alternative" type) + "multipart alternative") + ((vm-mime-types-match "multipart" type) + (let ((n (length (vm-mm-layout-parts layout)))) + (format "multipart message (%d part%s)" n (if (= n 1) "" "s")))) + ((vm-mime-types-match "text/plain" type) + (format "plain text%s" + (let ((charset (vm-mime-get-parameter layout "charset"))) + (if charset + (concat ", " charset) + "")))) + ((vm-mime-types-match "text/enriched" type) + "enriched text") + ((vm-mime-types-match "text/html" type) + "HTML") + ((vm-mime-types-match "image/gif" type) + "GIF image") + ((vm-mime-types-match "image/jpeg" type) + "JPEG image") + ((and (vm-mime-types-match "application/octet-stream" type) + (setq name (vm-mime-get-parameter layout "name")) + (save-match-data (not (string-match "^[ \t]*$" name)))) + name) + (t type))))) + +(defun vm-mime-layout-contains-type (layout type) + (if (vm-mime-types-match type (car (vm-mm-layout-type layout))) + layout + (let ((p (vm-mm-layout-parts layout)) + (result nil) + (done nil)) + (while (and p (not done)) + (if (setq result (vm-mime-layout-contains-type (car p) type)) + (setq done t) + (setq p (cdr p)))) + result ))) + +(defun vm-mime-plain-message-p (m) + (save-match-data + (let ((o (vm-mm-layout m)) + (case-fold-search t)) + (and (eq (vm-mm-encoded-header m) 'none) + (or (not (vectorp o)) + (and (vm-mime-types-match "text/plain" + (car (vm-mm-layout-type o))) + (string-match "^\\(us-ascii\\|iso-8859-1\\)$" + (or (vm-mime-get-parameter o "charset") + "us-ascii")) + (string-match "^\\(7bit\\|8bit\\|binary\\)$" + (vm-mm-layout-encoding o)))))))) + +(defun vm-mime-text-type-p (layout) + (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) + (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) + +(defun vm-mime-charset-internally-displayable-p (name) + (cond ((and (vm-xemacs-mule-p) (eq (device-type) 'x)) + (cdr (assoc (downcase name) vm-mime-xemacs-mule-charset-alist))) + ((vm-xemacs-p) + (vm-member (downcase name) '("us-ascii" "iso-8859-1"))) + ((vm-fsfemacs-19-p) + (vm-member (downcase name) '("us-ascii" "iso-8859-1"))))) + +(defun vm-mime-find-message/partials (layout id) + (let ((list nil) + (type (vm-mm-layout-type layout))) + (cond ((vm-mime-types-match "multipart" (car type)) + (let ((parts (vm-mm-layout-parts layout)) o) + (while parts + (setq o (vm-mime-find-message/partials (car parts) id)) + (if o + (setq list (nconc o list))) + (setq parts (cdr parts))))) + ((vm-mime-types-match "message/partial" (car type)) + (if (equal (vm-mime-get-parameter layout "id") id) + (setq list (cons layout list))))) + list )) + +(defun vm-message-at-point () + (let ((mp vm-message-list) + (point (point)) + (done nil)) + (while (and mp (not done)) + (if (and (>= point (vm-start-of (car mp))) + (<= point (vm-end-of (car mp)))) + (setq done t) + (setq mp (cdr mp)))) + (car mp))) + +(defun vm-mime-make-multipart-boundary () + (let ((boundary (make-string 40 ?a)) + (i 0)) + (random t) + (while (< i (length boundary)) + (aset boundary i (aref vm-mime-base64-alphabet + (% (vm-abs (lsh (random) -8)) + (length vm-mime-base64-alphabet)))) + (vm-increment i)) + boundary )) + +(defun vm-mime-attach-file (file type &optional charset) + "Attach a file to a VM composition buffer to be sent along with the message. +The file is not inserted into the buffer and MIME encoded until +you execute vm-mail-send or vm-mail-send-and-exit. A visible tag +indicating the existence of the attachment is placed in the +composition buffer. You can move the attachment around or remove +it entirely with normal text editing commands. If you remove the +attachment tag, the attachment will not be sent. + +First argument, FILE, is the name of the file to attach. Second +argument, TYPE, is the MIME Content-Type of the file. Optional +third argument CHARSET is the character set of the attached +document. This argument is only used for text types, and it +is ignored for other types. + +When called interactively all arguments are read from the +minibuffer. + +This command is for attaching files that do not have a MIME +header section at the top. For files with MIME headers, you +should use vm-mime-attach-mime-file to attach such a file. VM +will extract the content type information from the headers in +this case and not prompt you for it in the minibuffer." + (interactive + ;; protect value of last-command and this-command + (let ((last-command last-command) + (this-command this-command) + (charset nil) + file default-type type) + (if (null vm-send-using-mime) + (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) + (setq file (vm-read-file-name "Attach file: " nil nil t) + default-type (or (vm-mime-default-type-from-filename file) + "application/octet-stream") + type (completing-read + (format "Content type (default %s): " + default-type) + vm-mime-type-completion-alist) + type (if (> (length type) 0) type default-type)) + (if (vm-mime-types-match "text" type) + (setq charset (completing-read "Character set (default US-ASCII): " + vm-mime-charset-completion-alist) + charset (if (> (length charset) 0) charset))) + (list file type charset))) + (if (null vm-send-using-mime) + (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) + (if (file-directory-p file) + (error "%s is a directory, cannot attach" file)) + (if (not (file-exists-p file)) + (error "No such file: %s" file)) + (if (not (file-readable-p file)) + (error "You don't have permission to read %s" file)) + (and charset (setq charset (list (concat "charset=" charset)))) + (vm-mime-attach-object file type charset nil)) + +(defun vm-mime-attach-mime-file (file) + "Attach a MIME encoded file to a VM composition buffer to be sent +along with the message. + +The file is not inserted into the buffer until you execute +vm-mail-send or vm-mail-send-and-exit. A visible tag indicating +the existence of the attachment is placed in the composition +buffer. You can move the attachment around or remove it entirely +with normal text editing commands. If you remove the attachment +tag, the attachment will not be sent. + +The sole argument, FILE, is the name of the file to attach. +When called interactively the FILE argument is read from the +minibuffer. + +This command is for attaching files that have a MIME +header section at the top. For files without MIME headers, you +should use vm-mime-attach-file to attach such a file. VM +will interactively query you for the file type information." + (interactive + ;; protect value of last-command and this-command + (let ((last-command last-command) + (this-command this-command) + file) + (if (null vm-send-using-mime) + (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) + (setq file (vm-read-file-name "Attach file: " nil nil t)) + (list file))) + (if (null vm-send-using-mime) + (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) + (if (file-directory-p file) + (error "%s is a directory, cannot attach" file)) + (if (not (file-exists-p file)) + (error "No such file: %s" file)) + (if (not (file-readable-p file)) + (error "You don't have permission to read %s" file)) + (vm-mime-attach-object file "MIME file" nil t)) + +(defun vm-mime-attach-object (object type params mimed) + (if (not (eq major-mode 'mail-mode)) + (error "Command must be used in a VM Mail mode buffer.")) + (let ((start (point)) + e tag-string) + (setq tag-string (format "[ATTACHMENT %s, %s]" object type)) + (insert tag-string "\n") + (cond ((fboundp 'make-overlay) + (setq e (make-overlay start (point) nil t nil)) + (overlay-put e 'face vm-mime-button-face)) + ((fboundp 'make-extent) + (setq e (make-extent start (1- (point)))) + (set-extent-property e 'start-open t) + (set-extent-property e 'face vm-mime-button-face))) + (vm-set-extent-property e 'duplicable t) +;; crashes XEmacs +;; (vm-set-extent-property e 'replicating t) + (vm-set-extent-property e 'vm-mime-type type) + (vm-set-extent-property e 'vm-mime-object object) + (vm-set-extent-property e 'vm-mime-params params) + (vm-set-extent-property e 'vm-mime-encoded mimed))) + +(defun vm-mime-default-type-from-filename (file) + (let ((alist vm-mime-attachment-auto-type-alist) + (case-fold-search t) + (done nil)) + (while (and alist (not done)) + (if (string-match (car (car alist)) file) + (setq done t) + (setq alist (cdr alist)))) + (and alist (cdr (car alist))))) + +(defun vm-remove-mail-mode-header-separator () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward (concat "^" mail-header-separator "$") nil t) + (progn + (delete-region (match-beginning 0) (match-end 0)) + t ) + nil ))) + +(defun vm-add-mail-mode-header-separator () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^$" nil t) + (replace-match mail-header-separator t t)))) + +(defun vm-mime-transfer-encode-region (encoding beg end crlf) + (let ((case-fold-search t)) + (cond ((string-match "^binary$" encoding) + (vm-mime-base64-encode-region beg end crlf) + (setq encoding "base64")) + ((string-match "^7bit$" encoding) t) + ((string-match "^base64$" encoding) t) + ((string-match "^quoted-printable$" encoding) t) + ;; must be 8bit + ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) + (vm-mime-qp-encode-region beg end) + (setq encoding "quoted-printable")) + ((eq vm-mime-8bit-text-transfer-encoding 'base64) + (vm-mime-base64-encode-region beg end crlf) + (setq encoding "base64")) + ((eq vm-mime-8bit-text-transfer-encoding 'send) t)) + encoding )) + +(defun vm-mime-transfer-encode-layout (layout) + (if (vm-mime-text-type-p layout) + (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) + (vm-mm-layout-body-start layout) + (vm-mm-layout-body-end layout) + t) + (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) + (vm-mm-layout-body-start layout) + (vm-mm-layout-body-end layout) + nil))) +(defun vm-mime-encode-composition () + "MIME encode the current buffer. +Attachment tags added to the buffer with vm-mime-attach-file are expanded +and the approriate content-type and boundary markup information is added." + (interactive) + (save-restriction + (widen) + (if (not (eq major-mode 'mail-mode)) + (error "Command must be used in a VM Mail mode buffer.")) + (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) + (error "Message is already MIME encoded.")) + (let ((8bit nil) + (just-one nil) + (boundary-positions nil) + already-mimed layout e e-list boundary + type encoding charset params object opoint-min) + (mail-text) + (setq e-list (if (fboundp 'extent-list) + (extent-list nil (point) (point-max)) + (overlays-in (point) (point-max))) + e-list (vm-delete (function + (lambda (e) + (vm-extent-property e 'vm-mime-object))) + e-list t) + e-list (sort e-list (function + (lambda (e1 e2) + (< (vm-extent-end-position e1) + (vm-extent-end-position e2)))))) + ;; If there's just one attachment and no other readable + ;; text in the buffer then make the message type just be + ;; the attachment type rather than sending a multipart + ;; message with one attachment + (setq just-one (and (= (length e-list) 1) + (looking-at "[ \t\n]*") + (= (match-end 0) + (vm-extent-start-position (car e-list))) + (save-excursion + (goto-char (vm-extent-end-position (car e-list))) + (looking-at "[ \t\n]*\\'")))) + (if (null e-list) + (progn + (narrow-to-region (point) (point-max)) + (setq charset (vm-determine-proper-charset (point-min) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point-min) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point-min) + (point-max) + t)) + (widen) + (vm-remove-mail-mode-header-separator) + (goto-char (point-min)) + (vm-reorder-message-headers + nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") + (insert "MIME-Version: 1.0\n") + (insert "Content-Type: text/plain; charset=" charset "\n") + (insert "Content-Transfer-Encoding: " encoding "\n") + (vm-add-mail-mode-header-separator)) + (while e-list + (setq e (car e-list)) + (if (or just-one (= (point) (vm-extent-start-position e))) + nil + (narrow-to-region (point) (vm-extent-start-position e)) + (setq charset (vm-determine-proper-charset (point-min) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point-min) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point-min) + (point-max) + t)) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (insert "Content-Type: text/plain; charset=" charset "\n") + (insert "Content-Transfer-Encoding: " encoding "\n\n") + (widen)) + (goto-char (vm-extent-end-position e)) + (narrow-to-region (point) (point)) + (setq object (vm-extent-property e 'vm-mime-object)) + (cond ((bufferp object) + (insert-buffer-substring object)) + ((stringp object) + (insert-file-contents-literally object))) + (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) + (setq layout (vm-mime-parse-entity + nil (list "text/plain" "charset=us-ascii") + "7bit") + type (car (vm-mm-layout-type layout)) + params (cdr (vm-mm-layout-type layout))) + (setq type (vm-extent-property e 'vm-mime-type) + params (vm-extent-property e 'vm-mime-parameters))) + (cond ((vm-mime-types-match "text" type) + (setq encoding + (vm-determine-proper-content-transfer-encoding + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max)) + encoding (vm-mime-transfer-encode-region + encoding + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max) + t)) + (setq 8bit (or 8bit (equal encoding "8bit")))) + ((or (vm-mime-types-match "message/rfc822" type) + (vm-mime-types-match "multipart" type)) + (setq opoint-min (point-min)) + (if (not already-mimed) + (setq layout (vm-mime-parse-entity + nil (list "text/plain" "charset=us-ascii") + "7bit"))) + ;; MIME messages of type "message" and + ;; "multipart" are required to have a non-opaque + ;; content transfer encoding. This means that + ;; if the user only wants to send out 7bit data, + ;; then any subpart that contains 8bit data must + ;; have an opaque (qp or base64) 8->7bit + ;; conversion performed on it so that the + ;; enclosing entity can use an non-opqaue + ;; encoding. + ;; + ;; message/partial requires a "7bit" encoding so + ;; force 8->7 conversion in that case. + (let ((vm-mime-8bit-text-transfer-encoding + (if (vm-mime-types-match "message/partial" type) + 'quoted-printable + vm-mime-8bit-text-transfer-encoding))) + (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout + (vm-mm-layout-parts layout))) + ;; now figure out a proper content trasnfer + ;; encoding value for the enclosing entity. + (re-search-forward "^\n" nil t) + (save-restriction + (narrow-to-region (point) (point-max)) + (setq encoding + (vm-determine-proper-content-transfer-encoding + (point-min) + (point-max)))) + (setq 8bit (or 8bit (equal encoding "8bit"))) + (goto-char (point-max)) + (widen) + (narrow-to-region opoint-min (point))) + (t + (vm-mime-base64-encode-region + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max)) + (setq encoding "base64"))) + (if just-one + nil + (goto-char (point-min)) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (if (not already-mimed) + nil + ;; trim headers + (vm-reorder-message-headers + nil '("Content-Description:" "Content-ID:") nil) + ;; remove header/text separator + (goto-char (1- (vm-mm-layout-body-start layout))) + (if (looking-at "\n") + (delete-char 1))) + (insert "Content-Type: " type) + (if params + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity params "; ") "\n") + (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) + (insert "\n")) + (insert "Content-Transfer-Encoding: " encoding "\n\n")) + (goto-char (point-max)) + (widen) + (delete-region (vm-extent-start-position e) + (vm-extent-end-position e)) + (vm-detach-extent e) + (setq e-list (cdr e-list))) + ;; handle the remaining chunk of text after the last + ;; extent, if any. + (if (or just-one (= (point) (point-max))) + nil + (setq charset (vm-determine-proper-charset (point) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point) + (point-max) + t)) + (setq 8bit (or 8bit (equal encoding "8bit"))) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (insert "Content-Type: text/plain; charset=" charset "\n") + (insert "Content-Transfer-Encoding: " encoding "\n\n") + (goto-char (point-max))) + (setq boundary (vm-mime-make-multipart-boundary)) + (mail-text) + (while (re-search-forward (concat "^--" + (regexp-quote boundary) + "\\(--\\)?$") + nil t) + (setq boundary (vm-mime-make-multipart-boundary)) + (mail-text)) + (goto-char (point-max)) + (or just-one (insert "\n--" boundary "--\n")) + (while boundary-positions + (goto-char (car boundary-positions)) + (insert "\n--" boundary "\n") + (setq boundary-positions (cdr boundary-positions))) + (if (and just-one already-mimed) + (progn + (goto-char (vm-mm-layout-header-start layout)) + ;; trim headers + (vm-reorder-message-headers + nil '("Content-Description:" "Content-ID:") nil) + ;; remove header/text separator + (goto-char (1- (vm-mm-layout-body-start layout))) + (if (looking-at "\n") + (delete-char 1)) + ;; copy remainder to enclosing entity's header section + (insert-buffer-substring (current-buffer) + (vm-mm-layout-header-start layout) + (vm-mm-layout-body-start layout)) + (delete-region (vm-mm-layout-header-start layout) + (vm-mm-layout-body-start layout)))) + (goto-char (point-min)) + (vm-remove-mail-mode-header-separator) + (vm-reorder-message-headers + nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") + (vm-add-mail-mode-header-separator) + (insert "MIME-Version: 1.0\n") + (if (not just-one) + (insert (if vm-mime-avoid-folding-content-type + "Content-Type: multipart/mixed; boundary=\"" + "Content-Type: multipart/mixed;\n\tboundary=\"") + boundary "\"\n") + (insert "Content-Type: " type) + (if params + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity params "; ") "\n") + (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) + (insert "\n")) + (if just-one + (insert "Content-Transfer-Encoding: " encoding "\n") + (if 8bit + (insert "Content-Transfer-Encoding: 8bit\n") + (insert "Content-Transfer-Encoding: 7bit\n"))))))) + +(defun vm-mime-fragment-composition (size) + (save-restriction + (widen) + (vm-unsaved-message "Fragmenting message...") + (let ((buffers nil) + (id (vm-mime-make-multipart-boundary)) + (n 1) + (the-end nil) + b header-start header-end master-buffer start end) + (vm-remove-mail-mode-header-separator) + ;; message/partial must have "7bit" content transfer + ;; encoding, so verify that everything has been encoded for + ;; 7bit transmission. + (let ((vm-mime-8bit-text-transfer-encoding + (if (eq vm-mime-8bit-text-transfer-encoding 'send) + 'quoted-printable + vm-mime-8bit-text-transfer-encoding))) + (vm-mime-map-atomic-layouts + 'vm-mime-transfer-encode-layout + (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") + "7bit")))) + (goto-char (point-min)) + (setq header-start (point)) + (search-forward "\n\n") + (setq header-end (1- (point))) + (setq master-buffer (current-buffer)) + (goto-char (point-min)) + (setq start (point)) + (while (not (eobp)) + (condition-case nil + (progn + (forward-char (max (- size 150) 2000)) + (beginning-of-line)) + (end-of-buffer (setq the-end t))) + (setq end (point)) + (setq b (generate-new-buffer (concat (buffer-name) " part " + (int-to-string n)))) + (setq buffers (cons b buffers)) + (set-buffer b) + (make-local-variable 'vm-send-using-mime) + (setq vm-send-using-mime nil) + (insert-buffer-substring master-buffer header-start header-end) + (goto-char (point-min)) + (vm-reorder-message-headers nil nil + "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") + (insert "MIME-Version: 1.0\n") + (insert (format + (if vm-mime-avoid-folding-content-type + "Content-Type: message/partial; id=%s; number=%d" + "Content-Type: message/partial;\n\tid=%s;\n\tnumber=%d") + id n)) + (if the-end + (if vm-mime-avoid-folding-content-type + (insert (format "; total=%d\n" n)) + (insert (format ";\n\ttotal=%d\n" n))) + (insert "\n")) + (insert "Content-Transfer-Encoding: 7bit\n") + (goto-char (point-max)) + (insert mail-header-separator "\n") + (insert-buffer-substring master-buffer start end) + (vm-increment n) + (set-buffer master-buffer) + (setq start (point))) + (vm-unsaved-message "Fragmenting message... done") + (nreverse buffers)))) + +(defun vm-mime-preview-composition () + "Show how the current composition buffer might be displayed +in a MIME-aware mail reader. VM copies and encodes the current +mail composition buffer and displays it as a mail folder. +Type `q' to quit this temp folder and return to composing your +message." + (interactive) + (if (not (eq major-mode 'mail-mode)) + (error "Command must be used in a VM Mail mode buffer.")) + (let ((temp-buffer nil) + (mail-buffer (current-buffer)) + e-list) + (unwind-protect + (progn + (mail-text) + (setq e-list (if (fboundp 'extent-list) + (extent-list nil (point) (point-max)) + (overlays-in (point) (point-max))) + e-list (vm-delete (function + (lambda (e) + (vm-extent-property e 'vm-mime-object))) + e-list t) + e-list (sort e-list (function + (lambda (e1 e2) + (< (vm-extent-end-position e1) + (vm-extent-end-position e2)))))) + (setq temp-buffer (generate-new-buffer "composition preview")) + (set-buffer temp-buffer) + ;; so vm-mime-encode-composition won't complain + (setq major-mode 'mail-mode) + (vm-insert-region-from-buffer mail-buffer) + (mapcar 'vm-copy-extent e-list) + (goto-char (point-min)) + (or (vm-mail-mode-get-header-contents "From") + (insert "From: " (or user-mail-address (user-login-name)) "\n")) + (or (vm-mail-mode-get-header-contents "Message-ID") + (insert "Message-ID: \n")) + (or (vm-mail-mode-get-header-contents "Date") + (insert "Date: " + (format-time-string "%a, %d %b %Y %H%M%S %Z" + (current-time)) + "\n")) + (and vm-send-using-mime + (null (vm-mail-mode-get-header-contents "MIME-Version:")) + (vm-mime-encode-composition)) + (goto-char (point-min)) + (insert (vm-leading-message-separator 'From_)) + (goto-char (point-max)) + (insert (vm-trailing-message-separator 'From_)) + (set-buffer-modified-p nil) + ;; point of no return, don't kill it if the user quits + (setq temp-buffer nil) + (let ((vm-auto-decode-mime-messages t) + (vm-auto-displayed-mime-content-types t)) + (vm-save-buffer-excursion + (vm-goto-new-folder-frame-maybe 'folder) + (vm-mode))) + (message + (substitute-command-keys + "Type \\[vm-quit] to continue composing your message")) + ;; temp buffer, don't offer to save it. + (setq buffer-offer-save nil) + (vm-display (or vm-presentation-buffer (current-buffer)) t + (list this-command) '(vm-mode startup))) + (and temp-buffer (kill-buffer temp-buffer))))) + +(defun vm-mime-composite-type-p (type) + (or (vm-mime-types-match "message" type) + (vm-mime-types-match "multipart" type))) + +(defun vm-mime-map-atomic-layouts (function list) + (while list + (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) + (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) + (funcall function (car list))) + (setq list (cdr list)))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-minibuf.el --- a/lisp/vm/vm-minibuf.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-minibuf.el Mon Aug 13 09:13:56 2007 +0200 @@ -182,18 +182,14 @@ (setq keymap (car keymaps)) (cond ((vm-mouse-xemacs-mouse-p) (define-key keymap 'button1 command) - (define-key keymap 'button2 command) - (define-key keymap 'button3 command)) + (define-key keymap 'button2 command)) ((vm-mouse-fsfemacs-mouse-p) (define-key keymap [down-mouse-1] 'ignore) (define-key keymap [drag-mouse-1] 'ignore) (define-key keymap [mouse-1] command) (define-key keymap [drag-mouse-2] 'ignore) (define-key keymap [down-mouse-2] 'ignore) - (define-key keymap [mouse-2] command) - (define-key keymap [drag-mouse-3] 'ignore) - (define-key keymap [down-mouse-3] 'ignore) - (define-key keymap [mouse-3] command))) + (define-key keymap [mouse-2] command))) (setq keymaps (cdr keymaps))))) (setq w (vm-get-buffer-window (current-buffer))) (setq q list @@ -266,7 +262,9 @@ (if (not multi-word) (define-key minibuffer-local-map "\r" 'vm-minibuffer-complete-word-and-exit)) - (read-string prompt))) + ;; evade the XEmacs dialox box, yeccch. + (let ((should-use-dialog-box nil)) + (read-string prompt)))) (defvar last-nonmenu-event) @@ -362,7 +360,9 @@ (defun vm-keyboard-read-file-name (prompt &optional dir default must-match initial history) "Like read-file-name, except HISTORY's value is unaltered." - (let ((oldvalue (symbol-value history))) + (let ((oldvalue (symbol-value history)) + ;; evade the XEmacs dialox box, yeccch. + (should-use-dialog-box nil)) (unwind-protect (condition-case nil (read-file-name prompt dir default must-match initial history) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-misc.el --- a/lisp/vm/vm-misc.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-misc.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Miscellaneous functions for VM -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -131,6 +131,13 @@ (vm-set-su-end-of (car mp) nil) (setq mp (cdr mp)))))) +(defun vm-check-for-killed-presentation () + (and (bufferp vm-presentation-buffer-handle) + (null (buffer-name vm-presentation-buffer-handle)) + (progn + (setq vm-presentation-buffer-handle nil + vm-presentation-buffer nil)))) + (defun vm-check-for-killed-folder () (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer)) (setq vm-mail-buffer nil))) @@ -237,6 +244,15 @@ (setq prev p p (cdr p)))) list )) +(defun vm-delete-directory-file-names (list) + (vm-delete 'file-directory-p list)) + +(defun vm-delete-backup-file-names (list) + (vm-delete 'backup-file-name-p list)) + +(defun vm-delete-auto-save-file-names (list) + (vm-delete 'auto-save-file-name-p list)) + (defun vm-delete-duplicates (list &optional all hack-addresses) "Delete duplicate equivalent strings from the list. If ALL is t, then if there is more than one occurrence of a string in the list, @@ -317,12 +333,18 @@ return-value )) ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) ((stringp object) (copy-sequence object)) + ((markerp object) (copy-marker object)) (t object))) (defun vm-xemacs-p () (let ((case-fold-search nil)) (string-match "XEmacs" emacs-version))) +(defun vm-xemacs-mule-p () + (and (vm-xemacs-p) + (fboundp 'set-file-coding-system) + (fboundp 'decode-coding-region))) + (defun vm-fsfemacs-19-p () (and (string-match "^19" emacs-version) (not (string-match "XEmacs\\|Lucid" emacs-version)))) @@ -490,3 +512,100 @@ (defun vm-buffer-string-no-properties () (vm-buffer-substring-no-properties (point-min) (point-max))) + +(defun vm-insert-region-from-buffer (buffer &optional start end) + (let ((target-buffer (current-buffer))) + (set-buffer buffer) + (save-restriction + (widen) + (or start (setq start (point-min))) + (or end (setq end (point-max))) + (set-buffer target-buffer) + (insert-buffer-substring buffer start end) + (set-buffer buffer)) + (set-buffer target-buffer))) + +(if (fboundp 'overlay-get) + (fset 'vm-extent-property 'overlay-get) + (fset 'vm-extent-property 'extent-property)) + +(if (fboundp 'overlay-put) + (fset 'vm-set-extent-property 'overlay-put) + (fset 'vm-set-extent-property 'set-extent-property)) + +(if (fboundp 'make-overlay) + (fset 'vm-make-extent 'make-overlay) + (fset 'vm-make-extent 'make-extent)) + +(if (fboundp 'overlay-end) + (fset 'vm-extent-end-position 'overlay-end) + (fset 'vm-extent-end-position 'extent-end-position)) + +(if (fboundp 'overlay-start) + (fset 'vm-extent-start-position 'overlay-start) + (fset 'vm-extent-start-position 'extent-start-position)) + +(if (fboundp 'delete-overlay) + (fset 'vm-detach-extent 'delete-overlay) + (fset 'vm-detach-extent 'detach-extent)) + +(if (fboundp 'overlay-properties) + (fset 'vm-extent-properties 'overlay-properties) + (fset 'vm-extent-properties 'extent-properties)) + +(defun vm-copy-extent (e) + (let ((props (vm-extent-properties e)) + (ee (vm-make-extent (vm-extent-start-position e) + (vm-extent-end-position e)))) + (while props + (vm-set-extent-property ee (car props) (car (cdr props))) + (setq props (cdr props))))) + +(defun vm-make-tempfile-name () + (let ((done nil) (pid (emacs-pid)) filename) + (while (not done) + (setq filename (format "%s/vm%d.%d" vm-temp-file-directory pid + vm-tempfile-counter) + vm-tempfile-counter (1+ vm-tempfile-counter) + done (not (file-exists-p filename)))) + filename )) + +(defun vm-insert-char (char &optional count ignored buffer) + (condition-case nil + (progn + (insert-char char count ignored buffer) + (fset 'vm-insert-char 'insert-char)) + (wrong-number-of-arguments + (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char) + (vm-insert-char char count ignored buffer)))) + +(defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer) + (if (and buffer (eq buffer (current-buffer))) + (insert-char char count) + (save-excursion + (set-buffer buffer) + (insert-char char count)))) + +(defun vm-symbol-lists-intersect-p (list1 list2) + (catch 'done + (while list1 + (and (memq (car list1) list2) + (throw 'done t)) + (setq list1 (cdr list1))) + nil )) + +(defun vm-set-buffer-variable (buffer var value) + (save-excursion + (set-buffer buffer) + (set var value))) + +(defsubst vm-with-string-as-temp-buffer (string function) + (let ((work-buffer nil)) + (unwind-protect + (save-excursion + (setq work-buffer (generate-new-buffer " *work*")) + (set-buffer work-buffer) + (insert string) + (funcall function) + (buffer-string)) + (and work-buffer (kill-buffer work-buffer))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-motion.el --- a/lisp/vm/vm-motion.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-motion.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Commands to move around in a VM folder -;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -19,6 +19,7 @@ (defun vm-record-and-change-message-pointer (old new) (intern (buffer-name) vm-buffers-needing-display-update) + (vm-garbage-collect-message) (setq vm-last-message-pointer old vm-message-pointer new vm-need-summary-pointer-update t)) @@ -275,7 +276,8 @@ (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) - (vm-display nil nil '(vm-Next-message) '(vm-Next-message)) + (vm-display nil nil '(vm-next-message-no-skip) + '(vm-next-message-no-skip)) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil)) (vm-next-message count nil t))) @@ -288,7 +290,8 @@ (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) - (vm-display nil nil '(vm-Previous-message) '(vm-Previous-message)) + (vm-display nil nil '(vm-previous-message-no-skip) + '(vm-previous-message-no-skip)) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil)) (vm-previous-message count))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-mouse.el --- a/lisp/vm/vm-mouse.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-mouse.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Mouse related functions and commands -;;; Copyright (C) 1995 Kyle E. Jones +;;; Copyright (C) 1995-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -48,14 +48,11 @@ (beginning-of-line) (if (let ((vm-follow-summary-cursor t)) (vm-follow-summary-cursor)) - (progn - (vm-select-folder-buffer) - (vm-preview-current-message)) + nil (setq this-command 'vm-scroll-forward) (call-interactively 'vm-scroll-forward))) - ((memq major-mode '(vm-mode vm-virtual-mode)) - (cond ((and (vm-mouse-fsfemacs-mouse-p) vm-url-browser) - (vm-mouse-popup-or-select event)))))) + ((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode)) + (vm-mouse-popup-or-select event)))) (defun vm-mouse-button-3 (event) (interactive "e") @@ -73,12 +70,15 @@ (vm-menu-popup-mode-menu event)) ((eq major-mode 'vm-mode) (vm-menu-popup-context-menu event)) + ((eq major-mode 'vm-presentation-mode) + (vm-menu-popup-context-menu event)) ((eq major-mode 'vm-virtual-mode) (vm-menu-popup-context-menu event)) ((eq major-mode 'mail-mode) (vm-menu-popup-mode-menu event)))))) (defun vm-mouse-3-help (object) + nil "Use mouse button 3 to see a menu of options.") (defun vm-mouse-get-mouse-track-string (event) @@ -114,25 +114,33 @@ (cond ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) - (let (o-list o menu (found nil)) + (let (o-list (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (cond ((overlay-get (car o-list) 'vm-url) (setq found t) - (vm-mouse-send-url-at-event event))) + (vm-mouse-send-url-at-event event)) + ((overlay-get (car o-list) 'vm-mime-function) + (setq found t) + (funcall (overlay-get (car o-list) 'vm-mime-function) + (car o-list)))) (setq o-list (cdr o-list))) (and (not found) (vm-menu-popup-context-menu event)))) ;; The XEmacs code is not actually used now, since all ;; selectable objects are handled by an extent keymap ;; binding that points to a more specific function. But ;; this might come in handy later if I want selectable - ;; objects that don't have an extent attached. + ;; objects that don't have an extent or extent keymap + ;; attached. ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event))) - (if (extent-at (point) (current-buffer) 'vm-url) - (vm-mouse-send-url-at-event event) - (vm-menu-popup-context-menu event))))) + (let (e) + (cond ((extent-at (point) (current-buffer) 'vm-url) + (vm-mouse-send-url-at-event event)) + ((setq e (extent-at (point) nil 'vm-mime-function)) + (funcall (extent-property e 'vm-mime-function) e)) + (t (vm-menu-popup-context-menu event))))))) (defun vm-mouse-send-url-at-event (event) (interactive "e") @@ -146,35 +154,39 @@ (vm-mouse-send-url-at-position (posn-point (event-start event)))))) (defun vm-mouse-send-url-at-position (pos &optional browser) - (cond ((vm-mouse-xemacs-mouse-p) - (let ((e (extent-at pos (current-buffer) 'vm-url)) - url) - (if (null e) - nil - (setq url (buffer-substring (extent-start-position e) - (extent-end-position e))) - (vm-mouse-send-url url browser)))) - ((vm-mouse-fsfemacs-mouse-p) - (let (o-list url o) - (setq o-list (overlays-at pos)) - (while (and o-list (null (overlay-get (car o-list) 'vm-url))) - (setq o-list (cdr o-list))) - (if (null o-list) - nil - (setq o (car o-list)) - (setq url (vm-buffer-substring-no-properties - (overlay-start o) - (overlay-end o))) - (vm-mouse-send-url url browser)))))) + (save-restriction + (widen) + (cond ((vm-mouse-xemacs-mouse-p) + (let ((e (extent-at pos (current-buffer) 'vm-url)) + url) + (if (null e) + nil + (setq url (buffer-substring (extent-start-position e) + (extent-end-position e))) + (vm-mouse-send-url url browser)))) + ((vm-mouse-fsfemacs-mouse-p) + (let (o-list url o) + (setq o-list (overlays-at pos)) + (while (and o-list (null (overlay-get (car o-list) 'vm-url))) + (setq o-list (cdr o-list))) + (if (null o-list) + nil + (setq o (car o-list)) + (setq url (vm-buffer-substring-no-properties + (overlay-start o) + (overlay-end o))) + (vm-mouse-send-url url browser))))))) (defun vm-mouse-send-url (url &optional browser) - (let ((browser (or browser vm-url-browser))) - (cond ((symbolp browser) - (funcall browser url)) - ((stringp browser) - (vm-unsaved-message "Sending URL to %s..." browser) - (vm-run-background-command browser url) - (vm-unsaved-message "Sending URL to %s... done" browser))))) + (if (string-match "^mailto:" url) + (vm-mail-to-mailto-url url) + (let ((browser (or browser vm-url-browser))) + (cond ((symbolp browser) + (funcall browser url)) + ((stringp browser) + (vm-unsaved-message "Sending URL to %s..." browser) + (vm-run-background-command browser url) + (vm-unsaved-message "Sending URL to %s... done" browser)))))) (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) (vm-unsaved-message "Sending URL to Netscape...") @@ -221,7 +233,7 @@ ((vm-mouse-fsfemacs-mouse-p) (if (null (lookup-key vm-mode-map [mouse-2])) (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) - (if (null (lookup-key vm-mode-map [down-mouse-3])) + (if vm-popup-menu-on-mouse-3 (progn (define-key vm-mode-map [mouse-3] 'ignore) (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) @@ -232,6 +244,31 @@ (defun vm-run-command (command &rest arg-list) (apply (function call-process) command nil nil nil arg-list)) +;; return t on zero exit status +;; return (exit-status . stderr-string) on nonzero exit status +(defun vm-run-command-on-region (start end output-buffer command + &rest arg-list) + (let ((tempfile nil) status errstring) + (unwind-protect + (progn + (setq tempfile (vm-make-tempfile-name)) + (setq status + (apply 'call-process-region + start end command nil + (list output-buffer tempfile) + nil arg-list)) + (cond ((equal status 0) t) + ((zerop (save-excursion + (set-buffer (find-file-noselect tempfile)) + (buffer-size))) + t) + (t (save-excursion + (set-buffer (find-file-noselect tempfile)) + (setq errstring (buffer-string)) + (kill-buffer nil) + (cons status errstring))))) + (vm-error-free-call 'delete-file tempfile)))) + ;; stupid yammering compiler (defvar vm-mouse-read-file-name-prompt) (defvar vm-mouse-read-file-name-dir) @@ -266,8 +303,9 @@ (setq vm-mouse-read-file-name-history history) (setq vm-mouse-read-file-name-prompt prompt) (setq vm-mouse-read-file-name-return-value nil) - (save-excursion - (vm-goto-new-frame 'completion)) + (if (and vm-frame-per-completion (vm-multiple-frames-possible-p)) + (save-excursion + (vm-goto-new-frame 'completion))) (switch-to-buffer (current-buffer)) (vm-mouse-read-file-name-event-handler) (save-excursion @@ -321,7 +359,9 @@ (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n ?\n) - (setq list (directory-files default-directory)) + (setq list (vm-delete-backup-file-names + (vm-delete-auto-save-file-names + (directory-files default-directory)))) (vm-show-list list 'vm-mouse-read-file-name-event-handler) (setq buffer-read-only t))) @@ -351,8 +391,9 @@ (setq vm-mouse-read-string-completion-list completion-list) (setq vm-mouse-read-string-multi-word multi-word) (setq vm-mouse-read-string-return-value nil) - (save-excursion - (vm-goto-new-frame 'completion)) + (if (and vm-frame-per-completion (vm-multiple-frames-possible-p)) + (save-excursion + (vm-goto-new-frame 'completion))) (switch-to-buffer (current-buffer)) (vm-mouse-read-string-event-handler) (save-excursion @@ -369,7 +410,7 @@ (defun vm-mouse-read-string-event-handler (&optional string) (let ((key-doc "Click here for keyboard interface.") (bs-doc " .... to go back one word.") - (done-doc " .... to when you're done.") + (done-doc " .... when you're done.") start list) (if string (cond ((equal string key-doc) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-page.el --- a/lisp/vm/vm-page.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-page.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Commands to move around within a VM message -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -28,18 +28,24 @@ (was-invisible nil)) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) - (if (null (vm-get-visible-buffer-window (current-buffer))) - (let ((point (point))) - (vm-display (current-buffer) t - '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message)) - ;; window start sticks to end of clip region when clip - ;; region moves back past it in the buffer. fix it. - (let ((w (vm-get-visible-buffer-window (current-buffer)))) + (and vm-presentation-buffer + (set-buffer vm-presentation-buffer)) + (let ((point (point)) + (w (vm-get-visible-buffer-window (current-buffer)))) + (if (or (null w) + (not (vm-frame-totally-visible-p (vm-window-frame w)))) + (progn + (vm-display (current-buffer) t + '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message)) + ;; window start sticks to end of clip region when clip + ;; region moves back past it in the buffer. fix it. + (setq w (vm-get-visible-buffer-window (current-buffer))) (if (= (window-start w) (point-max)) - (set-window-start w (point-min)))) - (setq was-invisible t))) + (set-window-start w (point-min))) + (setq was-invisible t)))) (if (or mp-changed was-invisible (and (eq vm-system-state 'previewing) (pos-visible-in-window-p @@ -103,14 +109,20 @@ (t (and (> (prefix-numeric-value arg) 0) (vm-howl-if-eom))))))) - (if (not (or vm-startup-message-displayed vm-inhibit-startup-message)) + (if (not vm-startup-message-displayed) (vm-display-startup-message))) (defun vm-scroll-forward-internal (arg) (let ((direction (prefix-numeric-value arg)) (w (selected-window))) (condition-case error-data - (progn (scroll-up arg) nil) + (progn + (if (and (> direction 0) + (pos-visible-in-window-p + (vm-text-end-of (car vm-message-pointer)))) + (signal 'end-of-buffer nil) + (scroll-up arg)) + nil ) (error (if (or (and (< direction 0) (> (point-min) (vm-text-of (car vm-message-pointer)))) @@ -237,7 +249,7 @@ ;; large, search just the head and the tail of the region since ;; they tend to contain the interesting text. (let ((search-limit vm-url-search-limit) - (search-pairs)) + search-pairs n) (if (and search-limit (> (- (point-max) (point-min)) search-limit)) (setq search-pairs (list (cons (point-min) (+ (point-min) (/ search-limit 2))) @@ -256,14 +268,18 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq e (make-extent (match-beginning 0) (match-end 0))) + (setq n 1) + (while (null (match-beginning n)) + (vm-increment n)) + (setq e (make-extent (match-beginning n) (match-end n))) (set-extent-property e 'vm-url t) (if vm-highlight-url-face (set-extent-property e 'face vm-highlight-url-face)) (if vm-url-browser (let ((keymap (make-sparse-keymap))) (define-key keymap 'button2 'vm-mouse-send-url-at-event) - (define-key keymap 'button3 'vm-menu-popup-url-browser-menu) + (if vm-popup-menu-on-mouse-3 + (define-key keymap 'button3 'vm-menu-popup-url-browser-menu)) (define-key keymap "\r" (function (lambda () (interactive) (vm-mouse-send-url-at-position (point))))) @@ -288,12 +304,21 @@ (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq o (make-overlay (match-beginning 0) (match-end 0))) + (setq n 1) + (while (null (match-beginning n)) + (vm-increment n)) + (setq o (make-overlay (match-beginning n) (match-end n))) (overlay-put o 'vm-url t) (if vm-highlight-url-face (overlay-put o 'face vm-highlight-url-face)) (if vm-url-browser - (overlay-put o 'mouse-face 'highlight))) + (let ((keymap (make-sparse-keymap))) + (overlay-put o 'mouse-face 'highlight) + (setq keymap (nconc keymap (current-local-map))) + (define-key keymap "\r" + (function (lambda () (interactive) + (vm-mouse-send-url-at-position (point))))) + (overlay-put o 'local-map keymap)))) (setq search-pairs (cdr search-pairs)))))))) (defun vm-energize-headers () @@ -324,9 +349,10 @@ (define-key keymap 'button2 (list 'lambda () '(interactive) (list 'popup-menu (list 'quote menu)))) - (define-key keymap 'button3 - (list 'lambda () '(interactive) - (list 'popup-menu (list 'quote menu)))) + (if vm-popup-menu-on-mouse-3 + (define-key keymap 'button3 + (list 'lambda () '(interactive) + (list 'popup-menu (list 'quote menu))))) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help) (set-extent-property e 'highlight t)) @@ -410,10 +436,48 @@ "Netscape") (t (symbol-name vm-url-browser))))) -(defun vm-preview-current-message () - (setq vm-system-state 'previewing) - (if vm-real-buffers - (vm-make-virtual-copy (car vm-message-pointer))) +(defun vm-energize-urls-in-message-region (&optional start end) + (save-excursion + (or start (setq start (vm-headers-of (car vm-message-pointer)))) + (or end (setq end (vm-text-end-of (car vm-message-pointer)))) + ;; energize the URLs + (if (or vm-highlight-url-face vm-url-browser) + (save-restriction + (widen) + (narrow-to-region start + end) + (vm-energize-urls))))) + +(defun vm-highlight-headers-maybe () + ;; highlight the headers + (if (or vm-highlighted-header-regexp + (and (vm-xemacs-p) vm-use-lucid-highlighting)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-end-of (car vm-message-pointer))) + (vm-highlight-headers)))) + +(defun vm-energize-headers-and-xfaces () + ;; energize certain headers + (if (and vm-use-menus (vm-menu-support-possible-p)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-of (car vm-message-pointer))) + (vm-energize-headers))) + ;; display xfaces, if we can + (if (and vm-display-xfaces + (vm-xemacs-p) + (vm-multiple-frames-possible-p) + (featurep 'xface)) + (save-restriction + (widen) + (narrow-to-region (vm-headers-of (car vm-message-pointer)) + (vm-text-of (car vm-message-pointer))) + (vm-display-xface)))) + +(defun vm-narrow-for-preview () (widen) ;; hide as much of the message body as vm-preview-lines specifies (narrow-to-region @@ -425,86 +489,104 @@ (goto-char (vm-text-of (car vm-message-pointer))) (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0)) (point)))) - (t (vm-text-end-of (car vm-message-pointer))))) - ;; highlight the headers - (if (or vm-highlighted-header-regexp - (and (vm-xemacs-p) vm-use-lucid-highlighting)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer))) - (vm-highlight-headers))) - ;; energize the URLs - (if (or vm-highlight-url-face vm-url-browser) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer))) - (vm-energize-urls))) - ;; energize certain headers - (if (and vm-use-menus (vm-menu-support-possible-p)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-energize-headers))) + (t (vm-text-end-of (car vm-message-pointer)))))) + +(defun vm-preview-current-message () + (vm-save-buffer-excursion + (setq vm-system-state 'previewing) + (if vm-real-buffers + (vm-make-virtual-copy (car vm-message-pointer))) + + ;; run the message select hooks. + (save-excursion + (vm-select-folder-buffer) + (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook) + (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) + (vm-run-message-hook (car vm-message-pointer) + 'vm-select-new-message-hook)) + (and vm-select-unread-message-hook + (vm-unread-flag (car vm-message-pointer)) + (vm-run-message-hook (car vm-message-pointer) + 'vm-select-unread-message-hook))) - ;; display xfaces, if we can - (if (and vm-display-xfaces - (vm-xemacs-p) - (vm-multiple-frames-possible-p) - (featurep 'xface)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-display-xface))) + (vm-narrow-for-preview) + (if (or vm-mime-display-function + (and vm-display-using-mime + (not (vm-mime-plain-message-p (car vm-message-pointer))))) + (let ((layout (vm-mm-layout (car vm-message-pointer)))) + (vm-make-presentation-copy (car vm-message-pointer)) + (vm-save-buffer-excursion + (vm-replace-buffer-in-windows (current-buffer) + vm-presentation-buffer)) + (set-buffer vm-presentation-buffer) + (setq vm-system-state 'previewing) + (vm-narrow-for-preview)) + (setq vm-presentation-buffer nil) + (and vm-presentation-buffer-handle + (vm-replace-buffer-in-windows vm-presentation-buffer-handle + (current-buffer)))) - (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook) - (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-new-message-hook)) - (and vm-select-unread-message-hook (vm-unread-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-unread-message-hook)) + ;; at this point the current buffer is the presentation buffer + ;; if we're using one for this message. + + (vm-energize-urls-in-message-region) + (vm-highlight-headers-maybe) + (vm-energize-headers-and-xfaces) - (if vm-honor-page-delimiters - (vm-narrow-to-page)) - (goto-char (vm-text-of (car vm-message-pointer))) - ;; If we have a window, set window start appropriately. - (let ((w (vm-get-visible-buffer-window (current-buffer)))) - (if w - (progn (set-window-start w (point-min)) - (set-window-point w (vm-text-of (car vm-message-pointer)))))) - (if (or (null vm-preview-lines) - (and (not vm-preview-read-messages) - (not (vm-new-flag (car vm-message-pointer))) - (not (vm-unread-flag (car vm-message-pointer))))) - (vm-show-current-message) - (vm-update-summary-and-mode-line))) + (if vm-honor-page-delimiters + (vm-narrow-to-page)) + (goto-char (vm-text-of (car vm-message-pointer))) + ;; If we have a window, set window start appropriately. + (let ((w (vm-get-visible-buffer-window (current-buffer)))) + (if w + (progn (set-window-start w (point-min)) + (set-window-point w (vm-text-of (car vm-message-pointer)))))) + (if (or (null vm-preview-lines) + (and (not vm-preview-read-messages) + (not (vm-new-flag (car vm-message-pointer))) + (not (vm-unread-flag (car vm-message-pointer))))) + (vm-show-current-message) + (vm-update-summary-and-mode-line)))) (defun vm-show-current-message () - (save-excursion - (save-excursion - (goto-char (point-min)) - (widen) - (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) - (if vm-honor-page-delimiters - (progn - (if (looking-at page-delimiter) - (forward-page 1)) - (vm-narrow-to-page)))) - ;; don't mark the message as read if the user can't see it! - (if (vm-get-visible-buffer-window (current-buffer)) - (progn - (setq vm-system-state 'showing) - (cond ((vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil))) - (cond ((vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil))) - (vm-update-summary-and-mode-line) - (vm-howl-if-eom)) - (vm-update-summary-and-mode-line))) + (and vm-display-using-mime + vm-auto-decode-mime-messages + (not vm-mime-decoded) + (not (vm-mime-plain-message-p (car vm-message-pointer))) + (vm-decode-mime-message)) + (vm-save-buffer-excursion + (save-excursion + (save-excursion + (goto-char (point-min)) + (widen) + (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) + (if vm-honor-page-delimiters + (progn + (if (looking-at page-delimiter) + (forward-page 1)) + (vm-narrow-to-page)))) + ;; don't mark the message as read if the user can't see it! + (if (vm-get-visible-buffer-window (current-buffer)) + (progn + (save-excursion + (setq vm-system-state 'showing) + (if vm-mail-buffer + (vm-set-buffer-variable vm-mail-buffer 'vm-system-state + 'showing)) + ;; We could be in the presentation buffer here. Since + ;; the presentation buffer's message pointer and sole + ;; message are a mockup, they will cause trouble if + ;; passed into the undo/update system. So we switch + ;; into the real message buffer to do attribute + ;; updates. + (vm-select-folder-buffer) + (cond ((vm-new-flag (car vm-message-pointer)) + (vm-set-new-flag (car vm-message-pointer) nil))) + (cond ((vm-unread-flag (car vm-message-pointer)) + (vm-set-unread-flag (car vm-message-pointer) nil)))) + (vm-update-summary-and-mode-line) + (vm-howl-if-eom)) + (vm-update-summary-and-mode-line)))) (defun vm-expose-hidden-headers () "Toggle exposing and hiding message headers that are normally not visible." @@ -512,7 +594,10 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) + (and vm-presentation-buffer + (set-buffer vm-presentation-buffer)) (vm-display (current-buffer) t '(vm-expose-hidden-headers) '(vm-expose-hidden-headers reading-message)) (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer))))) @@ -561,7 +646,10 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) + (and vm-presentation-buffer + (set-buffer vm-presentation-buffer)) (vm-widen-page) (push-mark) (vm-display (current-buffer) t '(vm-beginning-of-message) @@ -583,7 +671,10 @@ (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) (vm-error-if-folder-empty) + (and vm-presentation-buffer + (set-buffer vm-presentation-buffer)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-pop.el --- a/lisp/vm/vm-pop.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-pop.el Mon Aug 13 09:13:56 2007 +0200 @@ -235,7 +235,13 @@ (vm-convert-folder-type-headers nil vm-folder-type) (goto-char end) (insert-before-markers (vm-trailing-message-separator)))) - (write-region start end crash t 0) + ;; Set file type to binary for DOS/Windows. I don't know if + ;; this is correct to do or not; it depends on whether the + ;; the CRLF or the LF newline convention is used on the inbox + ;; associated with this crashbox. This setting assumes the LF + ;; newline convention is used. + (let ((buffer-file-type t)) + (write-region start end crash t 0)) (delete-region start end) t )) @@ -262,7 +268,7 @@ (insert string) (call-process-region (point-min) (point-max) "/bin/sh" t buffer nil - "-c" vm-pop-md5-program) + shell-command-switch vm-pop-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. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-reply.el --- a/lisp/vm/vm-reply.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-reply.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Mailing, forwarding, and replying commands for VM -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -29,11 +29,12 @@ ((eq mlist mp) (cond ((setq to (let ((reply-to - (vm-get-header-contents (car mp) "Reply-To:"))) + (vm-get-header-contents (car mp) "Reply-To:" + ", "))) (if (vm-ignored-reply-to reply-to) nil reply-to )))) - ((setq to (vm-get-header-contents (car mp) "From:"))) + ((setq to (vm-get-header-contents (car mp) "From:" ", "))) ;; bad, but better than nothing for some ((setq to (vm-grok-From_-author (car mp)))) (t (error "No From: or Reply-To: header in message"))) @@ -51,9 +52,11 @@ subject) 0))) (setq subject (concat vm-reply-subject-prefix subject)))) - (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:")) + (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:" + ", ")) (setq to (concat to "," tmp))) - ((setq tmp (vm-get-header-contents (car mp) "From:")) + ((setq tmp (vm-get-header-contents (car mp) "From:" + ", ")) (setq to (concat to "," tmp))) ;; bad, but better than nothing for some ((setq tmp (vm-grok-From_-author (car mp))) @@ -61,8 +64,10 @@ (t (error "No From: or Reply-To: header in message"))))) (if to-all (progn - (setq tmp (vm-get-header-contents (car mp) "To:")) - (setq tmp2 (vm-get-header-contents (car mp) "Cc:")) + (setq tmp (vm-get-header-contents (car mp) "To:" + ", ")) + (setq tmp2 (vm-get-header-contents (car mp) "Cc:" + ", ")) (if tmp (if cc (setq cc (concat cc "," tmp)) @@ -72,13 +77,14 @@ (setq cc (concat cc "," tmp2)) (setq cc tmp2))))) (setq references - (cons (vm-get-header-contents (car mp) "References:") - (cons (vm-get-header-contents (car mp) "In-reply-to:") - (cons (vm-get-header-contents (car mp) "Message-ID:") + (cons (vm-get-header-contents (car mp) "References:" " ") + (cons (vm-get-header-contents (car mp) "In-reply-to:" " ") + (cons (vm-get-header-contents (car mp) "Message-ID:" + " ") references)))) (setq newsgroups - (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:")) - (vm-get-header-contents (car mp) "Newsgroups:")) + (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:" ",")) + (vm-get-header-contents (car mp) "Newsgroups:" ",")) newsgroups)) (setq mp (cdr mp))) (if vm-strip-reply-headers @@ -192,6 +198,8 @@ (setq newbuf (current-buffer)) (if (not (eq major-mode 'vm-mode)) (vm-mode)) + (if vm-presentation-buffer-handle + (vm-bury-buffer vm-presentation-buffer-handle)) (if (null vm-message-pointer) (error "No messages in folder %s" folder)) (setq default (vm-number-of (car vm-message-pointer))) @@ -275,12 +283,34 @@ (save-restriction (widen) (save-excursion - (set-buffer (vm-buffer-of message)) - (save-restriction - (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)))) + (if (vectorp (vm-mm-layout message)) + (let* ((o (vm-mm-layout message)) + (type (car (vm-mm-layout-type o))) + parts) + (vm-insert-region-from-buffer (vm-buffer-of message) + (vm-headers-of message) + (vm-text-of message)) + (cond ((vm-mime-types-match "multipart" type) + (setq parts (vm-mm-layout-parts o))) + (t (setq parts (list o)))) + (while parts + (cond ((vm-mime-text-type-p (car parts)) + (if (vm-mime-display-internal-text/plain (car parts) t) + nil + ;; charset problems probably + ;; just dump the raw bits + (vm-mime-insert-mime-body (car parts)) + (vm-mime-transfer-decode-region (car parts) + start (point))))) + (setq parts (cdr parts))) + (setq end (point-marker))) + (set-buffer (vm-buffer-of message)) + (save-restriction + (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)) @@ -290,11 +320,14 @@ "Just like mail-send-and-exit except that VM flags the appropriate message(s) as having been replied to, if appropriate." (interactive "P") + (vm-check-for-killed-folder) (let ((b (current-buffer))) (vm-mail-send) (cond ((null (buffer-name b)) ;; dead buffer (vm-display nil nil '(vm-mail-send-and-exit) - '(vm-mail-send-and-exit reading-message startup))) + '(vm-mail-send-and-exit + reading-message + startup))) (t (vm-display b nil '(vm-mail-send-and-exit) '(vm-mail-send-and-exit reading-message startup)) @@ -337,27 +370,78 @@ (interactive) (if vm-tale-is-an-idiot (vm-help-tale)) - (if (and vm-confirm-mail-send - (not (y-or-n-p "Send the message? "))) - (error "Message not sent.")) + ;; protect value of this-command from minibuffer read + (let ((this-command this-command)) + (if (and vm-confirm-mail-send + (not (y-or-n-p "Send the message? "))) + (error "Message not sent."))) + ;; send mail using MIME if user requests it and if the buffer + ;; has not already been MIME encoded. + (if (and vm-send-using-mime + (null (vm-mail-mode-get-header-contents "MIME-Version:"))) + (vm-mime-encode-composition)) ;; this to prevent Emacs 19 from asking whether a message that ;; has already been sent should be sent again. VM renames mail ;; buffers after the message has been sent, so the user should ;; already know that the message has been sent. (set-buffer-modified-p t) - ;; don't want a buffer change to occur here - ;; save-excursion to be sure. - (save-excursion - (mail-send)) - (vm-rename-current-mail-buffer) - (cond ((eq vm-system-state 'replying) - (vm-mail-mark-replied)) - ((eq vm-system-state 'forwarding) - (vm-mail-mark-forwarded)) - ((eq vm-system-state 'redistributing) - (vm-mail-mark-redistributed))) - (vm-keep-mail-buffer (current-buffer)) - (vm-display nil nil '(vm-mail-send) '(vm-mail-send))) + (let ((composition-buffer (current-buffer)) + ;; preserve these in case the composition buffer gets + ;; killed. + (vm-reply-list vm-reply-list) + (vm-forward-list vm-forward-list) + (vm-redistribute-list vm-redistribute-list)) + ;; fragment message using message/partial if it is too big. + (if (and vm-send-using-mime + (integerp vm-mime-max-message-size) + (> (buffer-size) vm-mime-max-message-size)) + (let (list) + (setq list (vm-mime-fragment-composition vm-mime-max-message-size)) + (while list + (save-excursion + (set-buffer (car list)) + (vm-mail-send) + (kill-buffer (car list))) + (setq list (cdr list))) + ;; what mail-send would have done + (set-buffer-modified-p nil)) + ;; don't want a buffer change to occur here + ;; save-excursion to be sure. + ;; + ;; also protect value of this-command from minibuffer reads + (let ((this-command this-command)) + (save-excursion + (mail-send)))) + (cond ((eq vm-system-state 'replying) + (vm-mail-mark-replied)) + ((eq vm-system-state 'forwarding) + (vm-mail-mark-forwarded)) + ((eq vm-system-state 'redistributing) + (vm-mail-mark-redistributed))) + ;; be careful, something could have killed the composition + ;; buffer inside mail-send. + (if (eq (current-buffer) composition-buffer) + (progn + (vm-rename-current-mail-buffer) + (vm-keep-mail-buffer (current-buffer)))) + (vm-display nil nil '(vm-mail-send) '(vm-mail-send)))) + +(defun vm-mail-mode-get-header-contents (header-name-regexp) + (let ((contents nil) + regexp) + (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^" + (regexp-quote mail-header-separator) "$\\)")) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (and (re-search-forward regexp nil t) + (match-beginning 1) + (progn (goto-char (match-beginning 0)) + (vm-match-header))) + (vm-matched-header-contents) + nil )))))) (defun vm-rename-current-mail-buffer () (if vm-rename-current-buffer-function @@ -503,6 +587,10 @@ (setq this-command 'vm-next-command-uses-marks) (command-execute 'vm-send-digest)) (let ((dir default-directory) + (miming (and vm-send-using-mime + (equal vm-forwarding-digest-type "mime"))) + mail-buffer + header-end boundary (mp vm-message-pointer)) (save-restriction (widen) @@ -518,10 +606,33 @@ (setq vm-system-state 'forwarding vm-forward-list (list (car mp)) default-directory dir) - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil 0) - (cond ((equal vm-forwarding-digest-type "rfc934") + (if miming + (progn + (setq mail-buffer (current-buffer)) + (set-buffer (generate-new-buffer "*vm-forward-buffer*")) + (setq header-end (point)) + (insert "\n")) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) + "\n")) + (goto-char (match-end 0)) + (setq header-end (match-beginning 0))) + (cond ((equal vm-forwarding-digest-type "mime") + (setq boundary (vm-mime-encapsulate-messages + (list (car mp)) vm-forwarded-headers + vm-unforwarded-header-regexp)) + (goto-char header-end) + (insert "MIME-Version: 1.0\n") + (insert (if vm-mime-avoid-folding-content-type + "Content-Type: multipart/digest; boundary=\"" + "Content-Type: multipart/digest;\n\tboundary=\"") + boundary "\"\n") + (insert "Content-Transfer-Encoding: " + (vm-determine-proper-content-transfer-encoding + (point) + (point-max)) + "\n")) + ((equal vm-forwarding-digest-type "rfc934") (vm-rfc934-encapsulate-messages vm-forward-list vm-forwarded-headers vm-unforwarded-header-regexp)) @@ -533,6 +644,17 @@ (vm-no-frills-encapsulate-message (car vm-forward-list) vm-forwarded-headers vm-unforwarded-header-regexp))) + (if miming + (let ((b (current-buffer))) + (set-buffer mail-buffer) + (mail-text) + (vm-mime-attach-object b "multipart/digest" + (list (concat "boundary=\"" + boundary "\"")) t) + (add-hook 'kill-buffer-hook + (list 'lambda () + (list 'if (list 'eq mail-buffer '(current-buffer)) + (list 'kill-buffer b)))))) (mail-position-on-field "To")) (run-hooks 'vm-forward-message-hook) (run-hooks 'vm-mail-mode-hook)))) @@ -548,20 +670,25 @@ (vm-error-if-folder-empty) (let ((b (current-buffer)) start (dir default-directory) + (layout (vm-mm-layout (car vm-message-pointer))) (lim (vm-text-end-of (car vm-message-pointer)))) (save-restriction (widen) - (save-excursion - (goto-char (vm-text-of (car vm-message-pointer))) - (let ((case-fold-search t)) - ;; What a wonderful world it would be if mailers used a single - ;; message encapsulation standard instead all the weird variants - ;; It is useless to try to cover them all. - ;; This simple rule should cover the sanest of the formats - (if (not (re-search-forward "^Received:" lim t)) - (error "This doesn't look like a bounced message.")) - (beginning-of-line) - (setq start (point)))) + (if (or (not (vectorp layout)) + (not (setq layout (vm-mime-layout-contains-type + layout "message/rfc822")))) + (save-excursion + (goto-char (vm-text-of (car vm-message-pointer))) + (let ((case-fold-search t)) + ;; What a wonderful world it would be if mailers + ;; used a single message encapsulation standard + ;; instead of all the weird variants. It is + ;; useless to try to cover them all. This simple + ;; rule should cover the sanest of the formats + (if (not (re-search-forward "^Received:" lim t)) + (error "This doesn't look like a bounced message.")) + (beginning-of-line) + (setq start (point))))) ;; briefly nullify vm-mail-header-from to keep vm-mail-internal ;; from inserting another From header. (let ((vm-mail-header-from nil)) @@ -569,7 +696,12 @@ (format "retry of bounce from %s" (vm-su-from (car vm-message-pointer))))) (goto-char (point-min)) - (insert-buffer-substring b start lim) + (if (vectorp layout) + (progn + (setq start (point)) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout start (point))) + (insert-buffer-substring b start lim)) (delete-region (point) (point-max)) (goto-char (point-min)) ;; delete all but pertinent headers @@ -658,13 +790,14 @@ (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((dir default-directory) - (mp vm-message-pointer) + (miming (and vm-send-using-mime (equal vm-digest-send-type "mime"))) + mp mail-buffer b ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-marked-or-prefixed-messages if we're using marks. (mlist (if (eq last-command 'vm-next-command-uses-marks) (vm-select-marked-or-prefixed-messages 0) vm-message-list)) - start) + start header-end boundary) (save-restriction (widen) (vm-mail-internal (format "digest from %s" (buffer-name))) @@ -672,14 +805,36 @@ (setq vm-system-state 'forwarding vm-forward-list mlist default-directory dir) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) - "\n")) - (goto-char (match-end 0)) - (setq start (point) - mp mlist) + (if miming + (progn + (setq mail-buffer (current-buffer)) + (set-buffer (generate-new-buffer "*vm-digest-buffer*")) + (setq header-end (point)) + (insert "\n") + (setq start (point-marker))) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) + "\n")) + (goto-char (match-end 0)) + (setq start (point-marker) + header-end (match-beginning 0))) (vm-unsaved-message "Building %s digest..." vm-digest-send-type) - (cond ((equal vm-digest-send-type "rfc934") + (cond ((equal vm-digest-send-type "mime") + (setq boundary (vm-mime-encapsulate-messages + mlist vm-mime-digest-headers + vm-mime-digest-discard-header-regexp)) + (goto-char header-end) + (insert "MIME-Version: 1.0\n") + (insert (if vm-mime-avoid-folding-content-type + "Content-Type: multipart/digest; boundary=\"" + "Content-Type: multipart/digest;\n\tboundary=\"") + boundary "\"\n") + (insert "Content-Transfer-Encoding: " + (vm-determine-proper-content-transfer-encoding + (point) + (point-max)) + "\n")) + ((equal vm-digest-send-type "rfc934") (vm-rfc934-encapsulate-messages mlist vm-rfc934-digest-headers vm-rfc934-digest-discard-header-regexp)) @@ -701,6 +856,17 @@ (center-line) (forward-char 1))) (setq mp (cdr mp))))) + (if miming + (let ((b (current-buffer))) + (set-buffer mail-buffer) + (mail-text) + (vm-mime-attach-object b "multipart/digest" + (list (concat "boundary=\"" + boundary "\"")) t) + (add-hook 'kill-buffer-hook + (list 'lambda () + (list 'if (list 'eq mail-buffer '(current-buffer)) + (list 'kill-buffer b)))))) (mail-position-on-field "To") (message "Building %s digest... done" vm-digest-send-type))) (run-hooks 'vm-send-digest-hook) @@ -718,6 +884,12 @@ (let ((vm-digest-send-type "rfc1153")) (vm-send-digest preamble))) +(defun vm-send-mime-digest (&optional preamble) + "Like vm-send-digest but always sends an MIME (multipart/digest) digest." + (interactive "P") + (let ((vm-digest-send-type "mime")) + (vm-send-digest preamble))) + (defun vm-continue-composing-message (&optional not-picky) "Find and select the most recently used mail composition buffer. If the selected buffer is already a Mail mode buffer then it is @@ -753,6 +925,14 @@ '(vm-continue-composing-message composing-message))) (message "No composition buffers found")))) +(defun vm-mail-to-mailto-url (url) + (let ((address (car (vm-parse url "^mailto:\\(.+\\)")))) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-mail-internal nil address) + (run-hooks 'vm-mail-hook) + (run-hooks 'vm-mail-mode-hook))) + ;; to quiet the v19 byte compiler (defvar mail-mode-map) (defvar mail-aliases) @@ -780,7 +960,7 @@ (nconc vm-mail-mode-map mail-mode-map) (setq vm-mail-mode-map-parented t)))) (setq vm-mail-buffer folder-buffer - mode-popup-menu (and vm-use-menus + mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 (vm-menu-support-possible-p) (vm-menu-mode-menu))) ;; sets up popup menu for FSF Emacs @@ -852,6 +1032,8 @@ vm-send-rfc934-digest-other-frame vm-send-rfc1153-digest vm-send-rfc1153-digest-other-frame + vm-send-mime-digest + vm-send-mime-digest-other-frame vm-forward-message vm-forward-message-other-frame vm-forward-message-all-headers @@ -985,3 +1167,14 @@ (vm-send-rfc1153-digest prefix)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) + +(defun vm-send-mime-digest-other-frame (&optional prefix) + "Like vm-send-mime-digest, but run in a newly created frame." + (interactive "P") + (if (vm-multiple-frames-possible-p) + (vm-goto-new-frame 'composition)) + (let ((vm-frame-per-composition nil) + (vm-search-other-frames nil)) + (vm-send-mime-digest prefix)) + (if (vm-multiple-frames-possible-p) + (vm-set-hooks-for-frame-deletion))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-save.el --- a/lisp/vm/vm-save.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-save.el Mon Aug 13 09:13:56 2007 +0200 @@ -142,7 +142,7 @@ (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line)) (if (zerop archived) - (message "No messages archived") + (message "No messages were archived") (message "%d message%s archived" archived (if (= 1 archived) "" "s"))))) @@ -486,7 +486,7 @@ (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))) (call-process-region (point-min) (point-max) (or shell-file-name "sh") - nil buffer nil "-c" command))) + nil buffer nil shell-command-switch command))) (setq mlist (cdr mlist))) (set-buffer buffer) (if (not (zerop (buffer-size))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-search.el --- a/lisp/vm/vm-search.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;;; Incremental search through a mail folder (for Lucid and FSF Emacs 19) -;;; Copyright (C) 1994 Kyle E. Jones -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 1, or (at your option) -;;; any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-search) - -(defun vm-isearch-forward (&optional arg) - "Incrementally search forward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (let ((vm-search-using-regexps - (if arg (not vm-search-using-regexps) vm-search-using-regexps))) - (vm-isearch t))) - -(defun vm-isearch-backward (&optional arg) - "Incrementally search backward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (let ((vm-search-using-regexps - (if arg (not vm-search-using-regexps) vm-search-using-regexps))) - (vm-isearch nil))) - -(defun vm-isearch (forward) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-error-if-virtual-folder) - (vm-display (current-buffer) t '(vm-isearch-forward vm-isearch-backward) - (list this-command 'searching-message)) - (let ((clip-head (point-min)) - (clip-tail (point-max)) - (old-vm-message-pointer vm-message-pointer)) - (unwind-protect - (progn (select-window (vm-get-visible-buffer-window (current-buffer))) - (widen) - (add-hook 'pre-command-hook 'vm-isearch-widen) - ;; order is significant, we want to narrow after - ;; the update - (add-hook 'post-command-hook 'vm-isearch-narrow) - (add-hook 'post-command-hook 'vm-isearch-update) - (isearch-mode forward vm-search-using-regexps nil t) - (vm-isearch-update) - (if (not (eq vm-message-pointer old-vm-message-pointer)) - (progn - (vm-record-and-change-message-pointer - old-vm-message-pointer vm-message-pointer) - (vm-update-summary-and-mode-line) - ;; vm-show-current-message only adjusts (point-max), - ;; it doesn't change (point-min). - (widen) - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (vm-text-end-of (car vm-message-pointer))) - (vm-display nil nil - '(vm-isearch-forward vm-isearch-backward) - '(reading-message)) - ;; turn the unwinds into a noop - (setq old-vm-message-pointer vm-message-pointer) - (setq clip-head (point-min)) - (setq clip-tail (point-max))))) - (remove-hook 'pre-command-hook 'vm-isearch-widen) - (remove-hook 'post-command-hook 'vm-isearch-update) - (remove-hook 'post-command-hook 'vm-isearch-narrow) - (narrow-to-region clip-head clip-tail) - (setq vm-message-pointer old-vm-message-pointer)))) - -(defun vm-isearch-widen () - (if (eq major-mode 'vm-mode) - (widen))) - -(defun vm-isearch-narrow () - (if (eq major-mode 'vm-mode) - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (vm-text-end-of (car vm-message-pointer))))) - -(defun vm-isearch-update () - (if (eq major-mode 'vm-mode) - (if (and (>= (point) (vm-start-of (car vm-message-pointer))) - (<= (point) (vm-end-of (car vm-message-pointer)))) - nil - (let ((mp vm-message-list) - (point (point))) - (while mp - (if (and (>= point (vm-start-of (car mp))) - (<= point (vm-end-of (car mp)))) - (setq vm-message-pointer mp mp nil) - (setq mp (cdr mp)))) - (setq vm-need-summary-pointer-update t) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-startup.el --- a/lisp/vm/vm-startup.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-startup.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Entry points for VM -;;; Copyright (C) 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1994-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -72,6 +72,7 @@ (vm-unsaved-message "Reading %s... done" file)))))))) (set-buffer folder-buffer) (vm-check-for-killed-summary) + (vm-check-for-killed-presentation) ;; If the buffer's not modified then we know that there can be no ;; messages in the folder that are not on disk. (or (buffer-modified-p) (setq vm-messages-not-on-disk 0)) @@ -85,7 +86,7 @@ ;; save file contains information the user might not ;; want overwritten, i.e. recover-file might be ;; desired. What we want to avoid is an auto-save. - ;; Making the folder read only will keep it + ;; Making the folder read only will keep ;; subsequent actions from modifying the buffer in a ;; way that triggers an auto save. ;; @@ -120,26 +121,20 @@ ;; make a new frame if the user wants one. reuse an ;; existing frame that is showing this folder. (if (and full-startup - vm-frame-per-folder - (vm-multiple-frames-possible-p) ;; this so that "emacs -f vm" doesn't create a frame. this-command) - (let ((w (or (vm-get-buffer-window (current-buffer)) - ;; summary == folder for the purpose - ;; of frame reuse. - (and vm-summary-buffer - (vm-get-buffer-window vm-summary-buffer))))) - (if (null w) - (progn - (if folder - (vm-goto-new-frame 'folder) - (vm-goto-new-frame 'primary-folder 'folder)) - (vm-set-hooks-for-frame-deletion)) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) - + (apply 'vm-goto-new-folder-frame-maybe + (if folder '(folder) '(primary-folder folder)))) + + ;; raise frame if requested and apply startup window + ;; configuration. + (if full-startup + (progn + (if vm-raise-frame-at-startup + (vm-raise-frame)) + (vm-display nil nil (list this-command) + (list (or this-command 'vm) 'startup)))) + ;; say this NOW, before the non-previewers read a message, ;; alter the new message count and confuse themselves. (if full-startup @@ -150,8 +145,6 @@ (if vm-message-list (vm-preview-current-message) (vm-update-summary-and-mode-line)) - (if full-startup - (vm-display (current-buffer) t nil nil)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (and (vm-toolbar-support-possible-p) vm-use-toolbar @@ -163,23 +156,29 @@ (vm-menu-install-visited-folders-menu)) (if full-startup - (save-excursion - (vm-display (current-buffer) t nil nil) - (if (and (vm-should-generate-summary) + (progn + (if (and (vm-should-generate-summary) ;; don't generate a summary if recover-file is ;; likely to happen, since recover-file does ;; nothing useful in a summary buffer. (not preserve-auto-save-file)) - (vm-summarize t)) - ;; People were confused that (vm) behaved differently - ;; than M-x vm. We used to list all the various VM - ;; startup commands here, but now we just accept any - ;; command and treat it as if it were VM. It's - ;; probably just as well, since any command that - ;; calls VM probably does want the window - ;; configuration to be setup. - (vm-display nil nil (list this-command) - (list (or this-command 'vm) 'startup)))) + (vm-summarize t nil)) + ;; raise the summary frame if the user wants frames + ;; raised and if there is a summary frame. + (if (and vm-summary-buffer + vm-frame-per-summary + vm-raise-frame-at-startup) + (vm-raise-frame)) + ;; if vm-mutable-windows is nil, the startup + ;; configuration can't be applied, so do + ;; something to get a VM buffer on the screen + (if vm-mutable-windows + (vm-display nil nil (list this-command) + (list (or this-command 'vm) 'startup)) + (save-excursion + (switch-to-buffer (or vm-summary-buffer + vm-presentation-buffer + (current-buffer))))))) (run-hooks 'vm-visit-folder-hook) @@ -213,8 +212,7 @@ ;; user says no. ;; Check this-command so we don't make the user wait if ;; they call vm non-interactively from some other program. - (if (and (not vm-inhibit-startup-message) - (not vm-startup-message-displayed) + (if (and (not vm-startup-message-displayed) (or (memq this-command '(vm vm-visit-folder)) ;; for emacs -f vm (null last-command))) @@ -253,7 +251,7 @@ (defun vm-mode (&optional read-only) "Major mode for reading mail. -This is VM 5.96 (beta). +This is VM 6.13. Commands: h - summarize folder contents @@ -293,7 +291,7 @@ @ - digestify and mail entire folder contents (the folder is not modified) * - burst a digest into individual messages, and append and assimilate these - message into the current folder. + messages into the current folder. G - sort messages by various keys @@ -322,14 +320,16 @@ M U - unmark the current message M m - mark all messages M u - unmark all messages - M C - mark messages matches by a virtual folder selector - M c - unmark messages matches by a virtual folder selector + M C - mark messages matched by a virtual folder selector + M c - unmark messages matched by a virtual folder selector M T - mark thread tree rooted at the current message M t - unmark thread tree rooted at the current message M S - mark messages with the same subject as the current message M s - unmark messages with the same subject as the current message M A - mark messages with the same author as the current message M a - unmark messages with the same author as the current message + M R - mark messages within the point/mark region in the summary + M r - unmark messages within the point/mark region in the summary M ? - partial help for mark commands @@ -376,17 +376,21 @@ vm-arrived-message-hook vm-arrived-messages-hook vm-auto-center-summary + vm-auto-decode-mime-messages + vm-auto-displayed-mime-content-types vm-auto-folder-alist vm-auto-folder-case-fold-search vm-auto-get-new-mail vm-auto-next-message vm-berkeley-mail-compatibility + vm-burst-digest-messages-inherit-labels vm-check-folder-types - vm-convert-folder-types vm-circular-folders vm-confirm-new-folders vm-confirm-quit + vm-convert-folder-types vm-crash-box + vm-crash-box-suffix vm-default-folder-type vm-delete-after-archiving vm-delete-after-bursting @@ -397,6 +401,7 @@ vm-digest-preamble-format vm-digest-send-type vm-display-buffer-hook + vm-display-using-mime vm-edit-message-hook vm-folder-directory vm-folder-read-only @@ -406,8 +411,11 @@ vm-forwarding-digest-type vm-forwarding-subject-format vm-frame-parameter-alist + vm-frame-per-completion vm-frame-per-composition + vm-frame-per-edit vm-frame-per-folder + vm-frame-per-summary vm-highlighted-header-face vm-highlighted-header-regexp vm-honor-page-delimiters @@ -416,32 +424,52 @@ vm-included-text-discard-header-regexp vm-included-text-headers vm-included-text-prefix - vm-inhibit-startup-message vm-invisible-header-regexp vm-jump-to-new-messages vm-jump-to-unread-messages + vm-keep-crash-boxes vm-keep-sent-messages - vm-keep-crash-boxes vm-mail-header-from vm-mail-mode-hook + vm-make-crash-box-name + vm-make-spool-file-name + vm-mime-8bit-composition-charset + vm-mime-8bit-text-transfer-encoding + vm-mime-alternative-select-method + vm-mime-attachment-auto-type-alist + vm-mime-attachment-save-directory + vm-mime-avoid-folding-content-type + vm-mime-base64-decoder-program + vm-mime-base64-decoder-switches + vm-mime-base64-encoder-program + vm-mime-base64-encoder-switches + vm-mime-button-face + vm-mime-digest-discard-header-regexp + vm-mime-digest-headers + vm-mime-display-function + vm-mime-external-content-types-alist + vm-mime-internal-content-types + vm-mime-max-message-size vm-mode-hook vm-mosaic-program vm-move-after-deleting + vm-move-after-killing vm-move-after-undeleting vm-move-messages-physically + vm-mutable-frames vm-mutable-windows - vm-mutable-frames vm-netscape-program - vm-options-file vm-pop-md5-program + vm-popup-menu-on-mouse-3 + vm-preferences-file vm-preview-lines vm-preview-read-messages vm-primary-inbox vm-quit-hook vm-recognize-pop-maildrops vm-reply-hook + vm-reply-ignored-addresses vm-reply-ignored-reply-tos - vm-reply-ignored-addresses vm-reply-subject-prefix vm-resend-bounced-discard-header-regexp vm-resend-bounced-headers @@ -459,9 +487,11 @@ vm-select-new-message-hook vm-select-unread-message-hook vm-send-digest-hook + vm-send-using-mime vm-skip-deleted-messages vm-skip-read-messages vm-spool-files + vm-spool-file-suffixes vm-startup-with-summary vm-strip-reply-headers vm-summary-arrow @@ -470,14 +500,16 @@ vm-summary-mode-hook vm-summary-redo-hook vm-summary-show-threads - vm-summary-subject-no-newlines vm-summary-thread-indent-level + vm-temp-file-directory + vm-tale-is-an-idiot vm-trust-From_-with-Content-Length vm-undisplay-buffer-hook vm-unforwarded-header-regexp vm-url-browser vm-url-search-limit vm-use-menus + vm-use-toolbar vm-virtual-folder-alist vm-virtual-mirror vm-visible-headers @@ -633,13 +665,15 @@ (use-local-map vm-mode-map) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) + (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) + (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) ;; save this for last in case the user interrupts. ;; an interrupt anywhere before this point will cause ;; everything to be redone next revisit. (setq major-mode 'vm-virtual-mode) (run-hooks 'vm-virtual-mode-hook) ;; must come after the setting of major-mode - (setq mode-popup-menu (and vm-use-menus + (setq mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 (vm-menu-support-possible-p) (vm-menu-mode-menu))) (setq blurb (vm-emit-totals-blurb)) @@ -651,35 +685,37 @@ (message blurb))) ;; make a new frame if the user wants one. reuse an ;; existing frame that is showing this folder. - (if (and vm-frame-per-folder (vm-multiple-frames-possible-p)) - (let ((w (or (vm-get-buffer-window (current-buffer)) - ;; summary == folder for the purpose - ;; of frame reuse. - (and vm-summary-buffer - (vm-get-buffer-window (current-buffer)))))) - (if (null w) - (vm-goto-new-frame 'folder) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))) - (vm-set-hooks-for-frame-deletion))) - (vm-display (current-buffer) t nil nil) + (vm-goto-new-folder-frame-maybe 'folder) + (if vm-raise-frame-at-startup + (vm-raise-frame)) + (vm-display nil nil (list this-command) (list this-command 'startup)) (and (vm-toolbar-support-possible-p) vm-use-toolbar (vm-toolbar-install-toolbar)) (if first-time - (if (vm-should-generate-summary) - (progn (vm-summarize t) - (message blurb)))) - (vm-display nil nil '(vm-visit-virtual-folder - vm-visit-virtual-folder-other-frame - vm-visit-virtual-folder-other-window - vm-create-virtual-folder - vm-apply-virtual-folder) - (list this-command 'startup)) + (progn + (if (vm-should-generate-summary) + (progn (vm-summarize t nil) + (message blurb))) + ;; raise the summary frame if the user wants frames + ;; raised and if there is a summary frame. + (if (and vm-summary-buffer + vm-frame-per-summary + vm-raise-frame-at-startup) + (vm-raise-frame)) + ;; if vm-mutable-windows is nil, the startup + ;; configuration can't be applied, so do + ;; something to get a VM buffer on the screen + (if vm-mutable-windows + (vm-display nil nil (list this-command) + (list (or this-command 'vm) 'startup)) + (save-excursion + (switch-to-buffer (or vm-summary-buffer + vm-presentation-buffer + (current-buffer))))))) + ;; check interactive-p so as not to bog the user down if they ;; run this function from within another function. - (and (interactive-p) (not vm-inhibit-startup-message) + (and (interactive-p) (not vm-startup-message-displayed) (vm-display-startup-message) (message blurb)))) @@ -768,6 +804,8 @@ 'vm-arrived-message-hook 'vm-arrived-messages-hook 'vm-auto-center-summary + 'vm-auto-decode-mime-messages + 'vm-auto-displayed-mime-content-types ;; don't send this by default, might be personal stuff in here. ;; 'vm-auto-folder-alist 'vm-auto-folder-case-fold-search @@ -780,6 +818,7 @@ 'vm-confirm-quit 'vm-convert-folder-types 'vm-crash-box + 'vm-crash-box-suffix 'vm-default-folder-type 'vm-delete-after-archiving 'vm-delete-after-bursting @@ -791,6 +830,7 @@ 'vm-digest-preamble-format 'vm-digest-send-type 'vm-display-buffer-hook + 'vm-display-using-mime 'vm-edit-message-hook 'vm-edit-message-mode 'vm-flush-interval @@ -802,8 +842,11 @@ 'vm-forwarding-digest-type 'vm-forwarding-subject-format 'vm-frame-parameter-alist + 'vm-frame-per-completion 'vm-frame-per-composition + 'vm-frame-per-edit 'vm-frame-per-folder + 'vm-frame-per-summary 'vm-highlight-url-face 'vm-highlighted-header-regexp 'vm-honor-page-delimiters @@ -812,7 +855,6 @@ 'vm-included-text-discard-header-regexp 'vm-included-text-headers 'vm-included-text-prefix - 'vm-inhibit-startup-message 'vm-init-file 'vm-invisible-header-regexp 'vm-jump-to-new-messages @@ -821,7 +863,26 @@ 'vm-keep-sent-messages 'vm-mail-header-from 'vm-mail-hook + 'vm-make-crash-box-name + 'vm-make-spool-file-name 'vm-mail-mode-hook + 'vm-mime-8bit-composition-charset + 'vm-mime-8bit-text-transfer-encoding + 'vm-mime-alternative-select-method + 'vm-mime-attachment-auto-type-alist + 'vm-mime-attachment-save-directory + 'vm-mime-avoid-folding-content-type + 'vm-mime-base64-decoder-program + 'vm-mime-base64-decoder-switches + 'vm-mime-base64-encoder-program + 'vm-mime-base64-encoder-switches + 'vm-mime-button-face + 'vm-mime-digest-discard-header-regexp + 'vm-mime-digest-headers + 'vm-mime-display-function + 'vm-mime-external-content-types-alist + 'vm-mime-internal-content-types + 'vm-mime-max-message-size 'vm-mode-hook 'vm-mode-hooks 'vm-mosaic-program @@ -832,8 +893,9 @@ 'vm-mutable-frames 'vm-mutable-windows 'vm-netscape-program - 'vm-options-file 'vm-pop-md5-program + 'vm-popup-menu-on-mouse-3 + 'vm-preferences-file 'vm-preview-lines 'vm-preview-read-messages 'vm-primary-inbox @@ -859,10 +921,12 @@ 'vm-select-new-message-hook 'vm-select-unread-message-hook 'vm-send-digest-hook + 'vm-send-using-mime 'vm-skip-deleted-messages 'vm-skip-read-messages ;; don't send vm-spool-files by default, might contain passwords ;; 'vm-spool-files + 'vm-spool-file-suffixes 'vm-startup-with-summary 'vm-strip-reply-headers 'vm-summary-format @@ -871,17 +935,18 @@ 'vm-summary-mode-hooks 'vm-summary-redo-hook 'vm-summary-show-threads - 'vm-summary-subject-no-newlines 'vm-summary-thread-indent-level 'vm-summary-uninteresting-senders 'vm-summary-uninteresting-senders-arrow 'vm-tale-is-an-idiot + 'vm-temp-file-directory 'vm-trust-From_-with-Content-Length 'vm-undisplay-buffer-hook 'vm-unforwarded-header-regexp 'vm-url-browser 'vm-url-search-limit 'vm-use-menus + 'vm-use-toolbar 'vm-virtual-folder-alist 'vm-virtual-mirror 'vm-visible-headers @@ -909,7 +974,22 @@ (setq vm-init-file-loaded t) (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) +(defun vm-check-emacs-version () + (cond ((and (vm-xemacs-p) + (or (< emacs-major-version 19) + (and (= emacs-major-version 19) + (< emacs-minor-version 14)))) + (error "VM %s must be run on XEmacs 19.14 or a later version." + vm-version)) + ((and (vm-fsfemacs-19-p) + (or (< emacs-major-version 19) + (and (= emacs-major-version 19) + (< emacs-minor-version 34)))) + (error "VM %s must be run on Emacs 19.34 or a later version." + vm-version)))) + (defun vm-session-initialization () + (vm-check-emacs-version) ;; If this is the first time VM has been run in this Emacs session, ;; do some necessary preparations. (if (or (not (boundp 'vm-session-beginning)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-summary.el --- a/lisp/vm/vm-summary.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-summary.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Summary gathering and formatting routines for VM -;;; Copyright (C) 1989, 1990, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ major-mode 'vm-summary-mode mode-line-format vm-mode-line-format ;; must come after the setting of major-mode - mode-popup-menu (and vm-use-menus + mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t @@ -38,7 +38,8 @@ (use-local-map vm-summary-mode-map) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) - (and (vm-mouse-support-possible-p) + (and vm-mouse-track-summary + (vm-mouse-support-possible-p) (vm-mouse-xemacs-mouse-p) (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) (if (or vm-frame-per-folder vm-frame-per-summary) @@ -50,12 +51,12 @@ (fset 'vm-summary-mode 'vm-mode) (put 'vm-summary-mode 'mode-class 'special) -(defun vm-summarize (&optional display) +(defun vm-summarize (&optional display raise) "Summarize the contents of the folder in a summary buffer. The format is as described by the variable vm-summary-format. Generally one line per message is most pleasing to the eye but this is not mandatory." - (interactive "p") + (interactive "p\np") (vm-select-folder-buffer) (vm-check-for-killed-summary) (if (null vm-summary-buffer) @@ -79,20 +80,11 @@ (vm-set-summary-redo-start-point t))) (if display (save-excursion - (if vm-frame-per-summary - (let ((w (vm-get-buffer-window vm-summary-buffer))) - (if (null w) - (progn - (vm-goto-new-frame 'summary) - (vm-set-hooks-for-frame-deletion)) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) + (vm-goto-new-summary-frame-maybe) (vm-display vm-summary-buffer t '(vm-summarize vm-summarize-other-frame) - (list this-command)) + (list this-command) (not raise)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (set-buffer vm-summary-buffer) @@ -118,7 +110,8 @@ ;; Just for laughs, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 10)) (mouse-track-func - (and (vm-mouse-support-possible-p) + (and vm-mouse-track-summary + (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) summary) @@ -188,7 +181,8 @@ (marker-buffer (vm-su-start-of m))) (let ((modified (buffer-modified-p)) (mouse-track-func - (and (vm-mouse-support-possible-p) + (and vm-mouse-track-summary + (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) summary) @@ -203,7 +197,7 @@ (goto-char (vm-su-start-of m)) (setq selected (not (looking-at vm-summary-no-=>))) ;; We do a little dance to update the text in - ;; order to make the markets in the text do + ;; order to make the markers in the text do ;; what we want. ;; ;; 1. We need to avoid having the su-start-of @@ -244,7 +238,8 @@ (if vm-summary-buffer (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) (mouse-track-func - (and (vm-mouse-support-possible-p) + (and vm-mouse-track-summary + (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) (old-window nil)) @@ -299,6 +294,13 @@ (if (and vm-summary-overlay (extent-end-position vm-summary-overlay)) (set-extent-endpoints vm-summary-overlay start end) (setq vm-summary-overlay (make-extent start end)) + ;; the reason this isn't needed under FSF Emacs is + ;; that insert-before-marker also inserts before + ;; overlays! so a summary update of an entry just + ;; before this overlay in the summary buffer won't + ;; leak into the overlay, but it _will_ leak into an + ;; XEmacs extent. + (set-extent-property vm-summary-overlay 'start-open t) (set-extent-property vm-summary-overlay 'detachable nil) (set-extent-property vm-summary-overlay 'face face))))) @@ -493,7 +495,7 @@ (put format-variable 'vm-compiled-format format) (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp)))) -(defun vm-get-header-contents (message header-name-regexp) +(defun vm-get-header-contents (message header-name-regexp &optional clump-sep) (let ((contents nil) regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)") @@ -504,12 +506,13 @@ (widen) (goto-char (vm-headers-of message)) (let ((case-fold-search t)) - (while (and (re-search-forward regexp (vm-text-of message) t) + (while (and (or (null contents) clump-sep) + (re-search-forward regexp (vm-text-of message) t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header))) (if contents (setq contents - (concat contents ", " (vm-matched-header-contents))) + (concat contents clump-sep (vm-matched-header-contents))) (setq contents (vm-matched-header-contents)))))) contents ))) @@ -612,18 +615,19 @@ nil (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (or (looking-at - ;; special case this so that the "remote from blah" - ;; isn't included. - "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") - (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))))))) + (save-excursion + (save-restriction + (widen) + (goto-char (vm-start-of message)) + (let ((case-fold-search nil)) + (if (or (looking-at + ;; special case this so that the "remote from blah" + ;; isn't included. + "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") + (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) + (vm-buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))))))) (defun vm-parse-date (date) (let ((weekday "") @@ -779,20 +783,21 @@ nil (save-excursion (set-buffer (vm-buffer-of message)) - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (looking-at "From \\([^ \t\n]+\\)") - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))))))) + (save-excursion + (save-restriction + (widen) + (goto-char (vm-start-of message)) + (let ((case-fold-search nil)) + (if (looking-at "From \\([^ \t\n]+\\)") + (vm-buffer-substring-no-properties + (match-beginning 1) + (match-end 1))))))))) (defun vm-su-do-author (m) (let ((full-name (vm-get-header-contents m "Full-Name:")) - (from (or (vm-get-header-contents m "From:") + (from (or (vm-get-header-contents m "From:" ", ") (vm-grok-From_-author m))) - pair) + pair i) (if (and full-name (string-match "^[ \t]*$" full-name)) (setq full-name nil)) (if (null from) @@ -806,6 +811,9 @@ (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) + (setq full-name (vm-decode-mime-encoded-words-maybe full-name)) + (while (setq i (string-match "\n" full-name i)) + (aset full-name i ?\ )) (vm-set-full-name-of m full-name) (vm-set-from-of m from))) @@ -862,37 +870,29 @@ (funcall vm-chop-full-name-function address))) (defun vm-su-do-recipients (m) - (let ((mail-use-rfc822 t) names addresses to cc all list) - (setq to (or (vm-get-header-contents m "To:") - (vm-get-header-contents m "Apparently-To:") + (let ((mail-use-rfc822 t) i names addresses to cc all list full-name) + (setq to (or (vm-get-header-contents m "To:" ", ") + (vm-get-header-contents m "Apparently-To:" ", ") ;; desperation.... (user-login-name)) - cc (vm-get-header-contents m "Cc:") + cc (vm-get-header-contents m "Cc:" ", ") all to all (if all (concat all ", " cc) cc) addresses (rfc822-addresses all)) (setq list (vm-parse-addresses all)) (while list - (cond ((string= (car list) "")) - ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>" - (car list)) - (if (match-beginning 2) - (setq names - (cons - (substring (car list) (match-beginning 2) - (match-end 2)) - names)) - (setq names - (cons - (substring (car list) (match-beginning 3) - (match-end 3)) - names)))) - ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list)) - (setq names - (cons (substring (car list) (match-beginning 1) - (match-end 1)) - names))) - (t (setq names (cons (car list) names)))) + ;; Just like vm-su-do-author: + (setq full-name (or (nth 0 (funcall vm-chop-full-name-function + (car list))) + (car list))) + ;; If double quoted are around the full name, fish the name out. + (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) + (setq full-name + (substring full-name (match-beginning 1) (match-end 1)))) + (setq full-name (vm-decode-mime-encoded-words-maybe full-name)) + (while (setq i (string-match "\n" full-name i)) + (aset full-name i ?\ )) + (setq names (cons full-name names)) (setq list (cdr list))) (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses (vm-set-to-of m (mapconcat 'identity addresses ", ")) @@ -941,11 +941,11 @@ (or (vm-subject-of m) (vm-set-subject-of m - (let ((subject (or (vm-get-header-contents m "Subject:") "")) + (let ((subject (or (vm-get-header-contents m "Subject:" " ") "")) (i nil)) - (if vm-summary-subject-no-newlines - (while (setq i (string-match "\n" subject i)) - (aset subject i ?\ ))) + (setq subject (vm-decode-mime-encoded-words-maybe subject)) + (while (setq i (string-match "\n" subject i)) + (aset subject i ?\ )) subject )))) (defun vm-su-summary (m) @@ -971,8 +971,8 @@ (while mp (vm-set-summary-of (car mp) nil) (vm-mark-for-summary-update (car mp)) - (vm-stuff-attributes (car mp)) (setq mp (cdr mp))) + (vm-stuff-folder-attributes nil) (set-buffer-modified-p t) (vm-update-summary-and-mode-line)) (vm-unsaved-message "Fixing your summary... done")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-thread.el --- a/lisp/vm/vm-thread.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-thread.el Mon Aug 13 09:13:56 2007 +0200 @@ -122,8 +122,7 @@ (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) (if (boundp loop-sym) ;; loop detected, bail... - (setq done t - thread-list (cdr thread-list)) + (setq done t) (set loop-sym t) (if (and (boundp id-sym) (symbol-value id-sym)) (progn @@ -212,12 +211,12 @@ (vm-set-parent-of m (or (let (references) - (setq references (vm-get-header-contents m "References:")) + (setq references (vm-get-header-contents m "References:" " ")) (and references (car (vm-last (vm-parse references "[^<]*\\(<[^>]+>\\)"))))) (let (in-reply-to) - (setq in-reply-to (vm-get-header-contents m "In-Reply-To:")) + (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ")) (and in-reply-to (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)")))))))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-toolbar.el --- a/lisp/vm/vm-toolbar.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-toolbar.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Toolbar related functions and commands -;;; Copyright (C) 1995 Kyle E. Jones +;;; Copyright (C) 1995-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -118,6 +118,24 @@ (or (fboundp 'vm-toolbar-compose-command) (fset 'vm-toolbar-compose-command 'vm-mail)) +(defvar vm-toolbar-decode-mime-button + [vm-toolbar-decode-mime-icon vm-toolbar-decode-mime-command + (vm-toolbar-can-decode-mime-p) + "Decode the MIME objects in the current message.\n +The objects might be displayed immediately, or buttons might be +displayed that you need to click on to view the object. See the +documentation for the variables vm-mime-internal-content-types +and vm-mime-external-content-types-alist to see how to control +whether you see buttons or objects.\n +The command `vm-toolbar-decode-mime-command' is run, which is normally +bound to `vm-decode-mime-messages'. +You can make this button run some other command by using a Lisp +s-expression like this one in your .vm file: + (fset 'vm-toolbar-decode-mime-command 'some-other-command)"]) +(defvar vm-toolbar-decode-mime-icon nil) +(or (fboundp 'vm-toolbar-decode-mime-command) + (fset 'vm-toolbar-decode-mime-command 'vm-decode-mime-message)) + (defvar vm-toolbar-delete-icon nil) (defvar vm-toolbar-undelete-icon nil) @@ -138,7 +156,8 @@ (make-variable-buffer-local 'vm-toolbar-helper-icon) (defvar vm-toolbar-help-button - [vm-toolbar-helper-icon vm-toolbar-helper-command t + [vm-toolbar-helper-icon vm-toolbar-helper-command + (vm-toolbar-can-help-p) "Don't Panic.\n VM uses this button to offer help if you're in trouble. Under normal circumstances, this button runs `vm-help'.\n @@ -154,7 +173,8 @@ (call-interactively vm-toolbar-helper-command)) (defvar vm-toolbar-quit-button - [vm-toolbar-quit-icon vm-toolbar-quit-command t + [vm-toolbar-quit-icon vm-toolbar-quit-command + (vm-toolbar-can-quit-p) "Quit visiting this folder.\n The command `vm-toolbar-quit-command' is run, which is normally bound to `vm-quit'. @@ -217,6 +237,25 @@ buffer-auto-save-file-name buffer-file-name)))) +(defun vm-toolbar-can-decode-mime-p () + (save-excursion + (vm-check-for-killed-folder) + (vm-select-folder-buffer) + (and + vm-display-using-mime + vm-message-pointer + vm-presentation-buffer + (not vm-mime-decoded) + (not (vm-mime-plain-message-p (car vm-message-pointer)))))) + +(defun vm-toolbar-can-quit-p () + (save-excursion + (vm-check-for-killed-folder) + (vm-select-folder-buffer) + (memq major-mode '(vm-mode vm-virtual-mode)))) + +(fset 'vm-toolbar-can-help-p 'vm-toolbar-can-quit-p) + (defun vm-toolbar-update-toolbar () (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer))) (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon) @@ -224,6 +263,9 @@ (cond ((vm-toolbar-can-recover-p) (setq vm-toolbar-helper-command 'recover-file vm-toolbar-helper-icon vm-toolbar-recover-icon)) + ((vm-toolbar-can-decode-mime-p) + (setq vm-toolbar-helper-command 'vm-decode-mime-message + vm-toolbar-helper-icon vm-toolbar-decode-mime-icon)) (t (setq vm-toolbar-helper-command 'vm-help vm-toolbar-helper-icon vm-toolbar-help-icon))) @@ -232,6 +274,11 @@ 'vm-toolbar-delete/undelete-icon 'vm-toolbar-helper-command 'vm-toolbar-helper-icon)) + (if vm-presentation-buffer + (vm-copy-local-variables vm-presentation-buffer + 'vm-toolbar-delete/undelete-icon + 'vm-toolbar-helper-command + 'vm-toolbar-helper-icon)) (and vm-toolbar-specifier (progn (set-specifier vm-toolbar-specifier (cons (current-buffer) nil)) @@ -242,7 +289,14 @@ (vm-toolbar-initialize) (let ((height (+ 4 (glyph-height (car vm-toolbar-help-icon)))) (width (+ 4 (glyph-width (car vm-toolbar-help-icon)))) + (myframe (vm-created-this-frame-p)) toolbar ) + ;; glyph-width and glyph-height return 0 at startup sometimes + ;; use reasonable values if they fail. + (if (= width 4) + (setq width 68)) + (if (= height 4) + (setq height 46)) ;; honor user setting of vm-toolbar if they are daring enough ;; to set it. (if vm-toolbar @@ -251,21 +305,29 @@ vm-toolbar toolbar)) (cond ((eq vm-toolbar-orientation 'right) (setq vm-toolbar-specifier right-toolbar) + (if myframe + (set-specifier right-toolbar (cons (selected-frame) toolbar))) (set-specifier right-toolbar (cons (current-buffer) toolbar)) (set-specifier right-toolbar-width (cons (selected-frame) width))) ((eq vm-toolbar-orientation 'left) (setq vm-toolbar-specifier left-toolbar) + (if myframe + (set-specifier left-toolbar (cons (selected-frame) toolbar))) (set-specifier left-toolbar (cons (current-buffer) toolbar)) (set-specifier left-toolbar-width (cons (selected-frame) width))) ((eq vm-toolbar-orientation 'bottom) (setq vm-toolbar-specifier bottom-toolbar) + (if myframe + (set-specifier bottom-toolbar (cons (selected-frame) toolbar))) (set-specifier bottom-toolbar (cons (current-buffer) toolbar)) (set-specifier bottom-toolbar-height (cons (selected-frame) height))) (t (setq vm-toolbar-specifier top-toolbar) + (if myframe + (set-specifier top-toolbar (cons (selected-frame) toolbar))) (set-specifier top-toolbar (cons (current-buffer) toolbar)) (set-specifier top-toolbar-height (cons (selected-frame) height)))))) @@ -277,6 +339,7 @@ (delete/undelete . vm-toolbar-delete/undelete-button) (file . vm-toolbar-file-button) (help . vm-toolbar-help-button) + (mime . vm-toolbar-decode-mime-button) (next . vm-toolbar-next-button) (previous . vm-toolbar-previous-button) (print . vm-toolbar-print-button) @@ -307,25 +370,33 @@ ((null vm-toolbar-help-icon) (let ((tuples (if (featurep 'xpm) - '( - (vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm") - (vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm" + (list + (if (>= (device-bitplanes) 16) + '(vm-toolbar-decode-mime-icon "mime-colorful-up.xpm" + "mime-colorful-dn.xpm" + "mime-colorful-xx.xpm") + '(vm-toolbar-decode-mime-icon "mime-simple-up.xpm" + "mime-simple-dn.xpm" + "mime-simple-xx.xpm")) + '(vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm") + '(vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm" "previous-dn.xpm") - (vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm") - (vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm" + '(vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm") + '(vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm" "undelete-dn.xpm") - (vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm" + '(vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm" "autofile-dn.xpm") - (vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm") - (vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm") - (vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm") - (vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm") - (vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm") - (vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm") - (vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm") - (vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm") + '(vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm") + '(vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm") + '(vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm") + '(vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm") + '(vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm") + '(vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm") + '(vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm") + '(vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm") ) '( + (vm-toolbar-decode-mime-icon "mime-up.xbm" "mime-dn.xbm" "mime-xx.xbm") (vm-toolbar-next-icon "next-up.xbm" "next-dn.xbm" "next-xx.xbm") (vm-toolbar-previous-icon "previous-up.xbm" "previous-dn.xbm" "previous-xx.xbm") @@ -359,5 +430,7 @@ files)) (setq tuples (cdr tuples))))))) (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) + (setq-default vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) (setq vm-toolbar-helper-command 'vm-help) - (setq vm-toolbar-helper-icon vm-toolbar-help-icon)) + (setq vm-toolbar-helper-icon vm-toolbar-help-icon) + (setq-default vm-toolbar-helper-icon vm-toolbar-help-icon)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-undo.el --- a/lisp/vm/vm-undo.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-undo.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Commands to undo message attribute changes in VM -;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones +;;; Copyright (C) 1989-1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-vars.el --- a/lisp/vm/vm-vars.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-vars.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; VM user and internal variable initialization -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -21,11 +21,10 @@ "*Startup file for VM that is loaded the first time you run VM in an Emacs session.") -(defvar vm-options-file "~/.vm.options" +(defvar vm-preferences-file "~/.vm.preferences" "*Secondary startup file for VM, loaded after vm-init-file. This file is written and overwritten by VM and is not meant for -users to edit directly. Use the Options menu to change what -appears in this file.") +users to edit directly.") (defvar vm-primary-inbox "~/INBOX" "*Mail is moved from the system mailbox to this file for reading.") @@ -136,6 +135,39 @@ variables are defined and no particular value for vm-spool-files has been specified.") +(defvar vm-spool-file-suffixes nil + "*List of suffixes to be used to create possible spool file names +for folders. Example: + + (setq vm-spool-file-suffixes '(\".spool\" \"-\")) + +If you visit a folder ~/mail/beekeeping, when VM attempts to +retrieve new mail for that folder it will look for mail in +~/mail/beekeeping.spool and ~/mail/beekeeping- in addition to +scanning vm-spool-files for matches. + +The value of vm-spool-files-suffixes will not be used unless +vm-crash-box-suffix is also defined, since a crash box is +required for all mail retrieval from spool files.") + +(defvar vm-crash-box-suffix nil + "*String suffix used to create possible crash box file names for folders. +When VM uses vm-spool-file-suffixes to create a spool file name, +it will append the value of vm-crash-box-suffix to the folder's +file name to create a crash box name.") + +(defvar vm-make-spool-file-name nil + "*Non-nil value should be a function that returns a spool file name +for a folder. The function will be called with one argument, the +folder's file name. If the folder does not have a file name, +the function will not be called.") + +(defvar vm-make-crash-box-name nil + "*Non-nil value should be a function that returns a crash box file name +for a folder. The function will be called with one argument, the +folder's file name. If the folder does not have a file name, +the function will not be called.") + (defvar vm-pop-md5-program "md5" "*Program that reads a message on its standard input and writes an MD5 digest on its output.") @@ -155,9 +187,7 @@ seconds) VM should check for new mail and try to retrieve it. This is done asynchronously and may occur while you are editing other files. It should not disturb your editing, except perhaps -for a pause while the work is being done. The `itimer' package -must be installed for this to work. Otherwise a numeric value is -the same as a value of t.") +for a pause while the check is being done.") (defvar vm-default-folder-type (cond ((not (boundp 'system-configuration)) @@ -282,9 +312,13 @@ (defvar vm-highlighted-header-face 'bold "*Face to be used to highlight headers. -This variable is ignored under Lucid Emacs. -See the documentation for the function `highlight-headers' -to find out how to customize header highlighting under Lucid Emacs.") +The header to highlight are sepcified by the vm-highlighted-header-regexp +variable. + +This variable is ignored under XEmacs if vm-use-lucid-highlighting is +nil. XEmacs' highlight-headers package is used instead. See the +documentation for the function `highlight-headers' to find out how to +customize header highlighting using this package.") (defvar vm-preview-lines 0 "*Non-nil value N causes VM to display the visible headers + N lines of text @@ -301,6 +335,290 @@ "*Non-nil value means to preview messages even if they've already been read. A nil value causes VM to preview messages only if new or unread.") +(defvar vm-display-using-mime t + "*Non-nil value means VM should display messages using MIME. +MIME (Multipurpose Internet Mail Extensions) is a set of +extensions to the standard Internet message format that allows +reliable tranmission and reception of arbitrary data including +images, audio and video as well as traditional text. + +A non-nil value for this variable means that VM will recognize +MIME encoded messages and display them as specified by the +various MIME standards specifications. + +A nil value means VM will not display MIME messages any +differently than any other message.") + +;; try to avoid bad interaction with TM +(defvar vm-send-using-mime (not (featurep 'mime-setup)) + "*Non-nil value means VM should support sending messages using MIME. +MIME (Multipurpose Internet Mail Extensions) is a set of +extensions to the standard Internet message format that allows +reliable tranmission and reception of arbitrary data including +images, audio and video as well as traditional text. + +A non-nil value for this variable means that VM will + + - allow you to attach files and messages to your outbound message. + - analyze the composition buffer when you send off a message and + encode it as needed. + +A nil value means VM will not offer any support for composing +MIME messages.") + +(defvar vm-honor-mime-content-disposition nil + "*Non-nil value means use information from the Content-Disposition header +to display MIME messages. The Content-Disposition header +specifies whether a MIME object should be displayed inline or +treated as an attachment. For VM, ``inline'' display means +displaying the object in the Emacs buffer, if possible. +Attachments will be displayed as a button that you can use +mouse-2 to activate or mouse-3 to pull up a menu of options.") + +(defvar vm-auto-decode-mime-messages nil + "*Non-nil value causes MIME decoding to occur automatically +when a message containing MIME objects is exposed. A nil value +means that you will have to run the `vm-decode-mime-message' +command (normally bound to `D') manually to decode and display +MIME objects.") + +(defvar vm-auto-displayed-mime-content-types '("text" "multipart") + "*List of MIME content types that should be displayed immediately +after decoding. Other types will be displayed as a button that +the user must activate to display the object. + +A value of t means that all types should be displayed immediately. +A nil value means never display MIME objects immediately; only use buttons. + +If the value is a list, it should be a list of strings, which +should all be types or type/subtype pairs. Example: + + (setq vm-auto-displayed-mime-content-types '(\"text\" \"image/jpeg\")) + +If a top-level type is listed without a subtype, all subtypes of +that type are assumed to be included. + +Note that some types are processed specially, and this variable does not +apply to them. + + Multipart/Digest and Message/RFC822 messages are always + displayed as a button to avoid visiting a new folder while the + user is moving around in the current folder. + + Message/Partial messages are always displayed as a button, + because there always needs to be a way to trigger the assembly + of the parts into a full message. + +Any type that cannot be displayed internally or externally will +be displayed as a button that allows you to save the body to a +file.") + +(defvar vm-mime-internal-content-types t + "*List of MIME content types that should be displayed internally +if Emacs is capable of doing so. A value of t means that VM +should always display an object internally if possible. A nil +value means never display MIME objects internally, which means VM +have to run an external viewer to display MIME objects. + +If the value is a list, it should be a list of strings. Example: + + (setq vm-mime-internal-content-types '(\"text\" \"image/jpeg\")) + +If a top-level type is listed without a subtype, all subtypes of +that type are assumed to be included. + +Note that all multipart types are always handled internally. +There is no need to list them here.") + +(defvar vm-mime-external-content-types-alist nil + "*Alist of MIME content types and the external programs used to display them. +If VM cannot display a type internally or has been instructed not +to (see the documentation for the vm-mime-internal-content-types +variable) it will try to launch an external program to display that +type. + +The alist format is + + ( (TYPE PROGRAM ARG ARG ... ) ... ) + +TYPE is a string specifying a MIME type or type/subtype pair. +Example \"text\" or \"image/jpeg\". If a top-level type is +listed without a subtype, all subtypes of that type are assumed +to be included. + +PROGRAM is a string naming a program to run to display an object. +Any ARGS will be passed to the program as arguments. The octets +that compose the object will be written into a file and the name +of the file will be passed to the program as its last argument. + +Example: + + (setq vm-mime-external-content-types-alist + '( + (\"text/html\" \"netscape\") + (\"image/gif\" \"xv\") + (\"image/jpeg\" \"xv\") + (\"video/mpeg\" \"mpeg_play\") + (\"video\" \"xanim\") + ) + ) + +The first matching list element will be used. + +No multipart message will ever be sent to an external viewer.") + +(defvar vm-mime-type-converter-alist nil + "*Alist of MIME types and programs that can convert between them. +If VM cannot display a content type, it will scan this list to +see if the type can be converted into a type that it can display. + +The alist format is + + ( (START-TYPE END-TYPE COMMAND-LINE ) ... ) + +START-TYPE is a string specifying a MIME type or type/subtype pair. +Example \"text\" or \"image/jpeg\". If a top-level type is +listed without a subtype, all subtypes of that type are assumed +to be included. + +END-TYPE must be an exact type/subtype pair. This is the type +to which START-TYPE will be converted. + +COMMAND-LINE is a string giving a command line to be passed to +the shell. The octets that compose the object will be written to +the standard input of the shell command. + +Example: + + (setq vm-mime-type-converter-alist + '( + (\"image/jpeg\" \"image/gif\" \"jpeg2gif\") + (\"text/html\" \"text/plain\" \"striptags\") + ) + ) + +The first matching list element will be used.") + +(defvar vm-mime-alternative-select-method 'best-internal + "*Value tells how to choose which multipart/alternative part to display. +A MIME message of type multipart/alternative has multiple message +parts containing the same information, but each part may be +formatted differently. VM will display only one of the parts. +This variable tells VM how to choose which part to display. + +A value of 'best means choose the part that is the most faithful to +the sender's original content that can be displayed. + +A value of 'best-internal means choose the best part that can be +displayed internally, i.e. with the built-in capabilities of Emacs. +If none of the parts can be displayed internally, behavior reverts to +that of 'best.") + +(defvar vm-mime-button-face + (cond ((fboundp 'find-face) + (or (and (not (eq (device-type) 'tty)) (find-face 'gui-button-face) + 'gui-button-face) + (and (find-face 'bold-italic) 'bold-italic))) + ((fboundp 'facep) + (or (and (facep 'gui-button-face) 'gui-button-face) + (and (facep 'bold-italic) 'bold-italic)))) + "*Face used for text in buttons that trigger the display of MIME objects.") + +(defvar vm-mime-8bit-composition-charset "iso-8859-1" + "*Character set that VM should assume if it finds non-US-ASCII characters +in a composition buffer. Composition buffers are assumed to use +US-ASCII unless the buffer contains a byte with the high bit set. +This variable specifies what character set VM should assume if +such a character is found.") + +(defvar vm-mime-8bit-text-transfer-encoding 'quoted-printable + "*Symbol specifying what kind of transfer encoding to use on 8bit +text. Characters with the high bit set cannot safely pass +through all mail gateways and mail transport software. MIME has +two transfer encodings that convert 8-bit data to 7-bit for same +transport. Quoted-printable leaves the text mostly readable even +if the recipent does not have a MIME-capable mail reader. BASE64 +is unreadable with a MIME-capable mail reader, unless your name +is U3BvY2s=. + +A value of 'quoted-printable, means to use quoted-printable encoding. +A value of 'base64 means to use BASE64 encoding. +A value of '8bit means to send the message as is. + +Note that this only applies to textual MIME content types. Images, audio, +video, etc. will always use BASE64 encoding. + +Note that lines of 1000 characters or longer will automatically +trigger BASE64 encoding. Carriage returns (ascii code 13) in the +text will also trigger BASE64 encoding.") + +(defvar vm-mime-attachment-auto-type-alist + '( + ("\\.jpe?g" . "image/jpeg") + ("\\.gif" . "image/gif") + ("\\.png" . "image/png") + ("\\.tiff" . "image/tiff") + ("\\.htm?l" . "text/html") + ("\\.au" . "audio/basic") + ("\\.mpe?g" . "video/mpeg") + ("\\.ps" . "application/postscript") + ) + "*Alist used to guess a MIME content type based on a file name. +The list format is + + ((REGEXP . TYPE) ...) + +REGEXP is a string that specifies a regular expression. +TYPE is a string specifying a MIME content type. + +When a non-MIME file is attached to a MIME composition buffer, +this list will be scanned until a REGEXP matches the file's name. +The corresponding TYPE will be offered as a default when you are +prompted for the file's type.") + +(defvar vm-mime-max-message-size nil + "*Largest MIME message that VM should send without fragmentation. +The value should be a integer which specifies the size in bytes. +A message larger than this value will be split into multiple parts +for transmission using the MIME message/partial type.") + +(defvar vm-mime-attachment-save-directory nil + "*Non-nil value is a default directory for saving MIME attachments. +When VM prompts you for a target file name when saving a MIME body, +any relative pathnames will be relative to this directory.") + +(defvar vm-mime-avoid-folding-content-type nil + "*Non-nil means don't send folded Content-Type headers in MIME messages. +`Folded' headers are headers broken into multiple lines as specified +in RFC822 for readability and to avoid excessive line lengths. At +least one major UNIX vendor ships a version of sendmail that believes +a folded Content-Type header is a syntax error, and returns any such +message to sender. A typical error message from such a sendmail +version is, + +553 header syntax error, line \" charset=us-ascii\" + +If you see one of these, setting vm-mime-avoid-folding-content-type +non-nil may let your mail get through.") + +(defvar vm-mime-base64-decoder-program nil + "*Non-nil value should be a string that names a MIME base64 decoder. +The program should expect to read base64 data on its standard +input and write the converted data to its standard output.") + +(defvar vm-mime-base64-decoder-switches nil + "*List of command line flags passed to the command named by +vm-mime-base64-decoder-program.") + +(defvar vm-mime-base64-encoder-program nil + "*Non-nil value should be a string that names a MIME base64 encoder. +The program should expect arbitrary data on its standard +input and write base64 data to its standard output.") + +(defvar vm-mime-base64-encoder-switches nil + "*List of command line flags passed to the command named by +vm-mime-base64-encoder-program.") + (defvar vm-auto-next-message t "*Non-nil value causes VM to use vm-next-message to advance to the next message in the folder if the user attempts to scroll past the end of the @@ -421,7 +739,7 @@ changed data into the folder buffer until a particular message or the whole folder is saved to disk. This makes normal Emacs auto-saving useless for VM folder buffers because the information -you'd want to auto-save, i.e. the attribute changes, isn't in +you'd want to auto-save, i.e. the attribute changes are not in the buffer when it is auto-saved. Setting vm-flush-interval to a numeric value will cause the VM's @@ -755,18 +1073,24 @@ vm-forwarded-headers list appearing last in the header section of the forwarded message.") -(defvar vm-forwarding-digest-type "rfc934" +(defvar vm-forwarding-digest-type "mime" "*Non-nil value should be a string that specifies the type of message encapsulation format to use when forwarding a message. Legal values of this variable are: \"rfc934\" \"rfc1153\" +\"mime\" nil A nil value means don't use a digest, just mark the beginning and end of the forwarded message.") +(defvar vm-burst-digest-messages-inherit-labels t + "*Non-nil values means messages from a digest inherit the digest's labels. +Labels are added to messages with vm-add-message-labels, normally +bound to `l a'.") + (defvar vm-digest-preamble-format "\"%s\" (%F)" "*String which specifies the format of the preamble lines generated by vm-send-digest when it is invoked with a prefix argument. One @@ -784,25 +1108,39 @@ "*Header to insert into messages burst from a digest. Value should be a format string of the same type as vm-summary-format that describes a header to be inserted into each message burst from a digest. The format string must end with a newline.") -(defvar vm-digest-burst-type "rfc934" +(defvar vm-digest-burst-type "guess" "*Value specifies the default digest type offered by vm-burst-digest when it asks you what type of digest you want to unpack. Allowed values of this variable are: \"rfc934\" \"rfc1153\" + \"mime\" \"guess\" +rfc1153 digests have a preamble, followed by a line of exactly 70 +dashes, with digested messages separated by lines of exactly 30 dashes. + +rfc934 digests separate messages on any line that begins with a few +dashes, but doesn't require lines with only dashes or lines with a +specific number of dashes. In the text of the message, any line +beginning with dashes is textually modified to be preceeded by a dash +and a space to prevent confusion with message separators. + +MIME digests use whatever boundary that is specified by the +boundary parameter in the Content-Type header of the digest. + If the value is \"guess\", and you take the default response when vm-burst-digest queries you, VM will try to guess the digest type.") -(defvar vm-digest-send-type "rfc934" +(defvar vm-digest-send-type "mime" "*String that specifies the type of digest vm-send-digest will use. Legal values of this variable are: \"rfc934\" \"rfc1153\" +\"mime\" ") @@ -896,8 +1234,56 @@ vm-rfc1153-digest-headers list appearing last in the headers of the digestified messages.") +(defvar vm-mime-digest-headers + '("Resent-" + "From:" "Sender:" + "To:" "Cc:" + "Subject:" + "Date:" + "Message-ID:" + "Keywords:" + "MIME-Version:" + "Content-") + "*List of headers that should be appear in MIME digests +created by VM. These should be listed in the order you wish them +to appear in the messages in the digest. Regular expressions are +allowed. There's no need to anchor patterns with \"^\", as +searches always start at the beginning of a line. Put a colon at +the end of patterns to get exact matches. (E.g. \"Date\" matches +\"Date\" and \"Date-Sent\".) Header names are always matched +case insensitively. + +If the value of vm-mime-digest-discard-header-regexp is nil, the headers +matched by vm-mime-digest-headers are the only headers that will be +kept. + +If vm-mime-digest-discard-header-regexp is non-nil, then only +headers matched by that variable will be discarded; all others +will be kept. vm-mime-digest-headers determines the order of +appearance in that case, with headers not matching any in the +vm-mime-digest-headers list appearing last in the headers +of the digestified messages.") + +(defvar vm-mime-digest-discard-header-regexp nil + "*Non-nil value should be a regular expression header that tells +which headers should not appear in MIME digests created +by VM. This variable along with vm-mime-digest-headers +determines which headers are kept and which are discarded. + +If the value of vm-mime-digest-discard-header-regexp is nil, the headers +matched by vm-mime-digest-headers are the only headers that will be +kept. + +If vm-mime-digest-discard-header-regexp is non-nil, then only +headers matched by this variable will be discarded; all others +will be kept. vm-mime-digest-headers determines the order of +appearance in that case, with headers not matching any in the +vm-mime-digest-headers list appearing last in the headers +of the digestified messages.") + (defvar vm-resend-bounced-headers - '("Resent-" + '("MIME-Version:" "Content-" + "Resent-" "From:" "Sender:" "Reply-To:" "To:" "Cc:" "Subject:" @@ -966,7 +1352,7 @@ (defvar vm-resend-discard-header-regexp "\\(\\(X400-\\)?Received:\\|Resent-\\)" "*Non-nil value should be a regular expression that tells what headers should not appear in a resent message. This -variable along with vm-resend-bounced-headers determines which +variable along with vm-resend-headers determines which headers are kept and which headers are discarded. If the value of vm-resend-discard-header-regexp is nil, @@ -1045,7 +1431,7 @@ the maximum allowed length of the substituted string. If the string is longer than this value the right end of the string is truncated. If the value is negative, the string is truncated on -on the left instead of the right. +the left instead of the right. The summary format need not be one line per message but it must end with a newline, otherwise the message pointer will not be displayed correctly @@ -1061,6 +1447,10 @@ "*Face to use to highlight the summary entry for the current message. Nil means don't highlight the current message's summary entry.") +(defvar vm-mouse-track-summary t + "*Non-nil value means highlight summary lines as the mouse passes +over them.") + (defvar vm-summary-show-threads nil "*Non-nil value means VM should display and maintain message thread trees in the summary buffer. This means that @@ -1121,10 +1511,6 @@ the arrow. A value that is not nil and not t causes VM to center the arrow only if the summary window is not the only existing window.") -(defvar vm-summary-subject-no-newlines t - "*Non-nil value means VM should replace newlines with spaces in the subject -displayed in the summary.") - (defvar vm-subject-ignored-prefix "^\\(re: *\\)+" "*Non-nil value should be a regular expression that matches strings at the beginning of the Subject header that you want VM to ignore @@ -1176,6 +1562,12 @@ under X Windows or some other window system that allows multiple Emacs frames.") +(defvar vm-raise-frame-at-startup t + "*Specifies whether VM should raise its frame at startup. +A value of nil means never raise the frame. +A value of t means always raise the frame. +Other values are reserved for future use.") + (defvar vm-frame-per-folder t "*Non-nil value causes the folder visiting commands to visit in a new frame. Nil means the commands will use the current frame. This variable @@ -1216,6 +1608,24 @@ under X Windows or some other window system that allows multiple Emacs frames.") +(defvar vm-frame-per-completion t + "*Non-nil value causes VM to open a new frame on mouse +initiated completing reads. A mouse initiated completing read +occurs when you invoke a VM command using the mouse, either with a +menu or a toolbar button. That command must then prompt you for +information, and there must be a limited set of proper responses. + +If these conditions are met and vm-frame-per-completion's value +is non-nil, VM will create a new frame containing a list of +responses that you can select with the mouse. + +A nil value means the current frame will be used to display the +list of choices. + +This variable has no meaning if you're not running Emacs native +under X Windows or some other window system that allows multiple +Emacs frames.") + (defvar vm-frame-parameter-alist nil "*Non-nil value is an alist of types and lists of frame parameters. This list tells VM what frame parameters to associate with each @@ -1223,12 +1633,15 @@ The alist should be of this form -((SYMBOL PARAMLIST) (SYMBOL2 PARAMLIST2) ...) - -SYMBOL must be one of `composition', `edit', `folder', -`primary-folder' or `summary'. It specifies the type of frame -that the following PARAMLIST applies to. - + ((SYMBOL PARAMLIST) (SYMBOL2 PARAMLIST2) ...) + +SYMBOL must be one of `completion', `composition', `edit', +`folder', `primary-folder' or `summary'. It specifies the type +of frame that the following PARAMLIST applies to. + +`completion' specifies parameters for frames that display list of + choices generated by a mouse-initiated completing read. + (See vm-frame-per-completion.) `composition' specifies parameters for mail composition frames. `edit' specifies parameters for message edit frames (e.g. created by vm-edit-message-other-frame) @@ -1236,7 +1649,7 @@ `vm-visit-' commands. `primary-folder' specifies parameters for the frame created by running `vm' without any arguments. -`summary' specifies parameters for frames to display a summary buffer +`summary' specifies parameters for frames that display a summary buffer (e.g. created by vm-summarize-other-frame) PARAMLIST is a list of pairs as described in the documentation for @@ -1258,18 +1671,19 @@ toolbar buttons will appears and in what order. Valid symbol value within the list are: -autofile -compose -delete/undelete -file -help -next -previous -print -quit -reply -visit -nil + autofile + compose + delete/undelete + file + help + mime + next + previous + print + quit + reply + visit + nil If nil appears in the list, it should appear exactly once. All buttons after nil in the list will be displayed flushright in @@ -1301,8 +1715,16 @@ Consider this variable experimental; it may not be supported forever.") -(defvar vm-use-menus '(folder motion send mark label sort - virtual undo dispose emacs nil help) +(defvar vm-use-menus + (nconc (list 'folder 'motion 'send 'mark 'label 'sort 'virtual) + (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) + nil) + (t (list 'undo))) + (list 'dispose) + (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) + nil) + (t (list 'emacs))) + (list nil 'help)) "*Non-nil value causes VM to provide a menu interface. A value that is a list causes VM to install its own menubar. A value of 1 causes VM to install a \"VM\" item in the Emacs menubar. @@ -1333,6 +1755,10 @@ are provided, which usually means Emacs has to be running under a window system.") +(defvar vm-popup-menu-on-mouse-3 t + "*Non-nil value means VM should provide context-sensitive menus on mouse-3. +A nil value means VM should not change the binding of mouse-3.") + (defvar vm-warp-mouse-to-new-frame nil "*Non-nil value causes VM to move the mouse cursor into newly created frames. This is useful to give the new frame the focus under some window managers @@ -1340,34 +1766,31 @@ Nil means don't move the mouse cursor.") -;; if browse-url is around (always will be in XEmacs 19.14 or later) use it; -;; otherwise do our own support. -(if (boundp 'browse-url-browser-function) - (defvaralias 'vm-url-browser 'browse-url-browser-function) - (defvar vm-url-browser - (cond ((fboundp 'w3-fetch-other-frame) - 'w3-fetch-other-frame) - ((fboundp 'w3-fetch) - 'w3-fetch) - (t 'vm-mouse-send-url-to-netscape)) - "*Non-nil value means VM should enable URL passing. -This means that VM will search for URLs (Universal Resource +(defvar vm-url-browser + (cond ((fboundp 'w3-fetch-other-frame) + 'w3-fetch-other-frame) + ((fboundp 'w3-fetch) + 'w3-fetch) + (t 'vm-mouse-send-url-to-netscape)) + "*Non-nil value means VM should enable URL passing. +This means that VM will search for URLs (Uniform Resource Locators) in messages and make it possible for you to pass them to a World Wide Web browser. Clicking mouse-2 on the URL will send it to the browser. -Clicking mouse-3 on the URL will pop up a menu of browsers and -you can pick which one you want to use. +By default clicking mouse-3 on the URL will pop up a menu of +browsers and you can pick which one you want to use. If +vm-popup-menu-on-mouse-3 is set to nil, you will not see the menu. Moving point to a character within the URL and pressing RETURN -will send the URL to the browser (Only in XEmacs). +will send the URL to the browser. If the value of vm-url-browser is a string, it should specify name of an external browser to run. The URL will be passed to the program as its first argument. -If the value of vm-url-browser is a symbol, if should specifiy a +If the value of vm-url-browser is a symbol, it should specify a Lisp function to call. The URL will be passed to the program as its first and only argument. Use @@ -1380,7 +1803,7 @@ for Mosaic. The advantage of using them is that they will display an URL using on existing Mosaic or Netscape process, if possible. -A nil value means VM should not enable URL passing to browsers.")) +A nil value means VM should not enable URL passing to browsers.") (defvar vm-highlight-url-face 'bold-italic "*Non-nil value should be a face to use display URLs found in messages. @@ -1465,6 +1888,14 @@ and not nil means that motion should be done as if vm-circular-folders is set to nil.") +(defvar vm-move-after-killing nil + "*Non-nil value causes VM's `k' command to automatically invoke +vm-next-message or vm-previous-message after killing messages, to try +to move past the deleted messages. A value of t means motion +should honor the value of vm-circular-folders. A value that is +not t and not nil means that motion should be done as if +vm-circular-folders is set to nil.") + (defvar vm-delete-after-saving nil "*Non-nil value causes VM automatically to mark messages for deletion after successfully saving them to a folder.") @@ -1516,7 +1947,7 @@ "*Command VM uses to print messages.") (defvar vm-print-command-switches lpr-switches - "*Command line flags passed to the command named by vm-print-command. + "*List of command line flags passed to the command named by vm-print-command. VM uses vm-print-command to print messages.") (defvar vm-berkeley-mail-compatibility @@ -1528,14 +1959,10 @@ (defvar vm-strip-reply-headers nil "*Non-nil value causes VM to strip away all comments and extraneous text from the headers generated in reply messages. If you use the \"fakemail\" -program as distributed with Emacs, you probably want to set this variable to +program as distributed with Emacs, you probably want to set this variable to t, because as of Emacs v18.52 \"fakemail\" could not handle unstripped headers.") -(defvar vm-inhibit-startup-message nil - "*Non-nil causes VM not to display its copyright notice, disclaimers -etc. when started in the usual way.") - (defvar vm-select-new-message-hook nil "*List of hook functions called every time a message with the 'new' attribute is made to be the current message. When the hooks are run the @@ -1701,6 +2128,17 @@ (defvar vm-menu-setup-hook nil "*List of hook functions that are run just after all menus are initialized.") +(defvar vm-mime-display-function nil + "*If non-nil, this should name a function to be called inside +vm-decode-mime-message to do the MIME display the current +message. The function is called with no arguments, and at the +time of the call the current buffer will be the `presentation' +buffer for the folder, which is a temporary buffer that VM uses +for the display of MIME messages. A copy of the current message +will be in the presentation buffer at that time. The normal work +that vm-decode-mime-message would do is not done, because this +function is expected to subsume all of it.") + (defvar mail-yank-hooks nil "Hooks called after a message is yanked into a mail composition. @@ -1756,6 +2194,10 @@ "*Name of program to use to run Mosaic. vm-mouse-send-url-to-mosaic uses this.") +(defvar vm-temp-file-directory "/tmp" + "*Name of a directory where VM can put temporary files. +This name must not end with a slash.") + (defvar vm-tale-is-an-idiot nil "*Non-nil value causes vm-mail-send to check multi-line recipient headers of outbound mail for lines that don't end with a @@ -1785,6 +2227,7 @@ (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-decode-mime-message) (define-key map "d" 'vm-delete-message) (define-key map "\C-d" 'vm-delete-message-backward) (define-key map "u" 'vm-undelete-message) @@ -1849,6 +2292,8 @@ (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 "MR" 'vm-mark-summary-region) + (define-key map "Mr" 'vm-unmark-summary-region) (define-key map "M?" 'vm-mark-help) (define-key map "W" (make-sparse-keymap)) (define-key map "WW" 'vm-apply-window-configuration) @@ -1884,6 +2329,10 @@ (defvar vm-mail-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-v" vm-mode-map) + (define-key map "\C-c\C-p" 'vm-mime-preview-composition) + (define-key map "\C-c\C-e" 'vm-mime-encode-composition) + (define-key map "\C-c\C-a" 'vm-mime-attach-file) + (define-key map "\C-c\C-m" 'vm-mime-attach-mime-file) (define-key map "\C-c\C-y" 'vm-yank-message) (define-key map "\C-c\C-s" 'vm-mail-send) (define-key map "\C-c\C-c" 'vm-mail-send-and-exit) @@ -1931,6 +2380,12 @@ (make-variable-buffer-local 'vm-last-message-pointer) (defvar vm-mail-buffer nil) (make-variable-buffer-local 'vm-mail-buffer) +(defvar vm-presentation-buffer nil) +(make-variable-buffer-local 'vm-presentation-buffer) +(defvar vm-presentation-buffer-handle nil) +(make-variable-buffer-local 'vm-presentation-buffer-handle) +(defvar vm-mime-decoded nil) +(make-variable-buffer-local 'vm-mime-decoded) (defvar vm-summary-buffer nil) (make-variable-buffer-local 'vm-summary-buffer) (defvar vm-summary-pointer nil) @@ -1958,6 +2413,7 @@ (make-variable-buffer-local 'vm-modification-counter) (defvar vm-flushed-modification-counter nil) (make-variable-buffer-local 'vm-flushed-modification-counter) +(defvar vm-tempfile-counter 0) (defvar vm-messages-needing-summary-update nil) (defvar vm-buffers-needing-display-update nil) (defvar vm-numbering-redo-start-point nil) @@ -2010,7 +2466,8 @@ (defconst vm-supported-folder-types '("From_" "From_-with-Content-Length" "mmdf" "babyl")) (defconst vm-supported-window-configurations - '(("default") + '( + ("default") ("startup") ("quitting") ("composing-message") @@ -2018,113 +2475,135 @@ ("marking-message") ("reading-message") ("searching-message") + ("vm") + ("vm-add-message-labels") + ("vm-apply-virtual-folder") + ("vm-auto-archive-messages") + ("vm-beginning-of-message") + ("vm-burst-digest") + ("vm-burst-mime-digest") + ("vm-burst-rfc1153-digest") + ("vm-burst-rfc934-digest") + ("vm-change-folder-type") + ("vm-clear-all-marks") + ("vm-continue-composing-message") + ("vm-create-virtual-folder") + ("vm-decode-mime-message") ("vm-delete-message") ("vm-delete-message-backward") - ("vm-undelete-message") - ("vm-kill-subject") - ("vm-expunge-folder") - ("vm-burst-digest") - ("vm-burst-rfc934-digest") - ("vm-burst-rfc1153-digest") + ("vm-delete-message-labels") + ("vm-discard-cached-data") ("vm-edit-message") - ("vm-discard-cached-data") + ("vm-edit-message-abort") ("vm-edit-message-end") - ("vm-edit-message-abort") - ("vm-unread-message") - ("vm-quit-no-change") + ("vm-edit-message-other-frame") + ("vm-end-of-message") + ("vm-expose-hidden-headers") + ("vm-expunge-folder") + ("vm-followup") + ("vm-followup-include-text") + ("vm-followup-include-text-other-frame") + ("vm-followup-other-frame") + ("vm-forward-message") + ("vm-forward-message-all-headers") + ("vm-forward-message-all-headers-other-frame") + ("vm-forward-message-other-frame") + ("vm-get-new-mail") + ("vm-goto-message") + ("vm-goto-message-last-seen") + ("vm-goto-parent-message") + ("vm-help") + ("vm-isearch-forward") + ("vm-kill-subject") + ("vm-load-init-file") + ("vm-mail") + ("vm-mail-other-frame") + ("vm-mail-other-window") + ("vm-mail-send") + ("vm-mail-send-and-exit") + ("vm-mark-all-messages") + ("vm-mark-help") + ("vm-mark-matching-messages") + ("vm-mark-message") + ("vm-mark-messages-same-author") + ("vm-mark-messages-same-subject") + ("vm-mark-summary-region") + ("vm-mark-thread-subtree") + ("vm-mode") + ("vm-move-message-backward") + ("vm-move-message-backward-physically") + ("vm-move-message-forward") + ("vm-move-message-forward-physically") + ("vm-next-command-uses-marks") + ("vm-next-message") + ("vm-next-message-no-skip") + ("vm-next-message-no-skip") + ("vm-next-message-same-subject") + ("vm-next-unread-message") + ("vm-other-frame") + ("vm-other-window") + ("vm-pipe-message-to-command") + ("vm-previous-message") + ("vm-previous-message-no-skip") + ("vm-previous-message-no-skip") + ("vm-previous-message-same-subject") + ("vm-previous-unread-message") ("vm-quit") + ("vm-quit-just-bury") + ("vm-quit-just-iconify") + ("vm-quit-no-change") + ("vm-reply") + ("vm-reply-include-text") + ("vm-reply-include-text-other-frame") + ("vm-reply-other-frame") + ("vm-resend-bounced-message") + ("vm-resend-bounced-message-other-frame") + ("vm-resend-message") + ("vm-resend-message-other-frame") + ("vm-save-and-expunge-folder") ("vm-save-buffer") - ("vm-write-file") ("vm-save-folder") - ("vm-save-and-expunge-folder") + ("vm-save-message") + ("vm-save-message-sans-headers") + ("vm-scroll-backward") + ("vm-scroll-forward") + ("vm-send-digest") + ("vm-send-digest-other-frame") + ("vm-send-mime-digest") + ("vm-send-mime-digest-other-frame") + ("vm-send-rfc1153-digest") + ("vm-send-rfc1153-digest-other-frame") + ("vm-send-rfc934-digest") + ("vm-send-rfc934-digest-other-frame") + ("vm-set-message-attributes") + ("vm-show-copying-restrictions") + ("vm-show-no-warranty") + ("vm-sort-messages") + ("vm-submit-bug-report") + ("vm-summarize") + ("vm-summarize-other-frame") + ("vm-toggle-read-only") + ("vm-toggle-threads-display") + ("vm-undelete-message") + ("vm-undo") + ("vm-unmark-matching-messages") + ("vm-unmark-message") + ("vm-unmark-messages-same-author") + ("vm-unmark-messages-same-subject") + ("vm-unmark-summary-region") + ("vm-unmark-thread-subtree") + ("vm-unread-message") + ("vm-virtual-help") ("vm-visit-folder") ("vm-visit-folder-other-frame") ("vm-visit-folder-other-window") - ("vm-help") - ("vm-get-new-mail") - ("vm-load-init-file") - ("vm") - ("vm-other-frame") - ("vm-other-window") - ("vm-toggle-read-only") - ("vm-mode") - ("vm-show-copying-restrictions") - ("vm-show-no-warranty") - ("vm-clear-all-marks") - ("vm-mark-all-messages") - ("vm-mark-message") - ("vm-unmark-message") - ("vm-mark-messages-same-subject") - ("vm-unmark-messages-same-subject") - ("vm-mark-messages-same-author") - ("vm-unmark-messages-same-author") - ("vm-mark-matching-messages") - ("vm-unmark-matching-messages") - ("vm-mark-thread-subtree") - ("vm-unmark-thread-subtree") - ("vm-next-command-uses-marks") - ("vm-mark-help") - ("vm-submit-bug-report") - ("vm-goto-message") - ("vm-goto-message-last-seen") - ("vm-next-message") - ("vm-previous-message") - ("vm-next-message-no-skip") - ("vm-previous-message-no-skip") - ("vm-next-unread-message") - ("vm-previous-unread-message") - ("vm-scroll-forward") - ("vm-scroll-backward") - ("vm-expose-hidden-headers") - ("vm-beginning-of-message") - ("vm-end-of-message") - ("vm-yank-message-other-folder") - ("vm-yank-message") - ("vm-mail-send-and-exit") - ("vm-mail-send") - ("vm-reply") - ("vm-reply-include-text") - ("vm-followup") - ("vm-followup-include-text") - ("vm-forward-message") - ("vm-forward-message-all-headers") - ("vm-mail") - ("vm-resend-bounced-message") - ("vm-resend-message") - ("vm-send-digest") - ("vm-send-rfc934-digest") - ("vm-send-rfc1153-digest") - ("vm-reply-other-frame") - ("vm-reply-include-text-other-frame") - ("vm-followup-other-frame") - ("vm-followup-include-text-other-frame") - ("vm-forward-message-other-frame") - ("vm-forward-message-all-headers-other-frame") - ("vm-mail-other-frame") - ("vm-mail-other-window") - ("vm-resend-bounced-message-other-frame") - ("vm-resend-message-other-frame") - ("vm-send-digest-other-frame") - ("vm-send-rfc934-digest-other-frame") - ("vm-send-rfc1153-digest-other-frame") - ("vm-continue-composing-message") - ("vm-auto-archive-messages") - ("vm-save-message") - ("vm-save-message-sans-headers") - ("vm-pipe-message-to-command") - ("vm-isearch-forward") - ("vm-move-message-forward") - ("vm-move-message-backward") - ("vm-move-message-forward-physically") - ("vm-move-message-backward-physically") - ("vm-sort-messages") - ("vm-toggle-threads-display") - ("vm-summarize") - ("vm-summarize-other-frame") - ("vm-undo") ("vm-visit-virtual-folder") ("vm-visit-virtual-folder-other-frame") - ("vm-visit-virtual-folder-other-window"))) + ("vm-visit-virtual-folder-other-window") + ("vm-write-file") + ("vm-yank-message") + ("vm-yank-message-other-folder") +)) (defconst vm-supported-sort-keys '("date" "reversed-date" "author" "reversed-author" @@ -2182,7 +2661,7 @@ "unanswered")) (defvar vm-key-functions nil) -(defconst vm-digest-type-alist '(("rfc934") ("rfc1153"))) +(defconst vm-digest-type-alist '(("rfc934") ("rfc1153") ("mime"))) (defvar vm-completion-auto-correct t "Non-nil means that minibuffer-complete-file should aggressively erase the trailing part of a word that caused completion to fail, and retry @@ -2195,11 +2674,12 @@ append a space to words that complete unambiguously.") (defconst vm-attributes-vector-length 9) (defconst vm-cache-vector-length 20) -(defconst vm-softdata-vector-length 16) +(defconst vm-softdata-vector-length 18) (defconst vm-location-data-vector-length 6) (defconst vm-mirror-data-vector-length 5) (defconst vm-startup-message-lines '("Please use \\[vm-submit-bug-report] to report bugs." + "For discussion about the VM mail reader, see the gnu.emacs.vm.info newsgroup" "You may give out copies of VM. Type \\[vm-show-copying-restrictions] to see the conditions" "VM comes with ABSOLUTELY NO WARRANTY; type \\[vm-show-no-warranty] for full details" "In Stereo (where available)")) @@ -2207,7 +2687,7 @@ ;; for the mode line (defvar vm-mode-line-format '("" " %&%& " - ("VM: " + ("VM " vm-version ": " (vm-folder-read-only "read-only ") (vm-virtual-folder-definition (vm-virtual-mirror "mirrored ")) "%b" @@ -2277,7 +2757,6 @@ (defvar vm-forward-list nil) (defvar vm-redistribute-list nil) (defvar current-itimer nil) -(defvar mode-popup-menu nil) (defvar current-menubar nil) (defvar scrollbar-height nil) (defvar top-toolbar nil) @@ -2292,8 +2771,11 @@ ;; is loaded before highlight-headers.el (defvar highlight-headers-regexp "Subject[ \t]*:") (defvar vm-url-regexp - "\\(file\\|ftp\\|gopher\\|http\\|https\\|news\\|wais\\|www\\)://[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]" - "Regular expression that matches an absolute URL.") + "]+\\)>\\|\\(\\(file\\|ftp\\|gopher\\|http\\|https\\|news\\|wais\\|www\\)://[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)\\|\\(mailto:[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)" + "Regular expression that matches an absolute URL. +The URL itself must be matched by a \\(..\\) grouping. +VM will extract the URL by copying the lowest number grouping +that has a match.") (defconst vm-month-alist '(("jan" "January" "1") ("feb" "February" "2") @@ -2322,3 +2804,115 @@ (defvar vm-delete-duplicates-obarray (make-vector 29 0)) (defvar vm-mail-mode-map-parented nil) (defvar vm-xface-cache (make-vector 29 0)) +(defconst vm-mime-base64-alphabet + (concat + [ + 65 66 67 68 69 70 71 72 73 74 75 76 77 + 78 79 80 81 82 83 84 85 86 87 88 89 90 + 97 98 99 100 101 102 103 104 105 106 107 108 109 + 110 111 112 113 114 115 116 117 118 119 120 121 122 + 48 49 50 51 52 53 54 55 56 57 43 47 + ] + )) +(defconst vm-mime-base64-alphabet-decoding-vector + [ + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 62 0 0 0 63 + 52 53 54 55 56 57 58 59 60 61 0 0 0 0 0 0 + 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + 15 16 17 18 19 20 21 22 23 24 25 0 0 0 0 0 + 0 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50 51 0 0 0 0 0 + ]) + +;;(defconst vm-mime-base64-alphabet-decoding-alist +;; '( +;; ( 65 . 00) ( 66 . 01) ( 67 . 02) ( 68 . 03) ( 69 . 04) ( 70 . 05) +;; ( 71 . 06) ( 72 . 07) ( 73 . 08) ( 74 . 09) ( 75 . 10) ( 76 . 11) +;; ( 77 . 12) ( 78 . 13) ( 79 . 14) ( 80 . 15) ( 81 . 16) ( 82 . 17) +;; ( 83 . 18) ( 84 . 19) ( 85 . 20) ( 86 . 21) ( 87 . 22) ( 88 . 23) +;; ( 89 . 24) ( 90 . 25) ( 97 . 26) ( 98 . 27) ( 99 . 28) (100 . 29) +;; (101 . 30) (102 . 31) (103 . 32) (104 . 33) (105 . 34) (106 . 35) +;; (107 . 36) (108 . 37) (109 . 38) (110 . 39) (111 . 40) (112 . 41) +;; (113 . 42) (114 . 43) (115 . 44) (116 . 45) (117 . 46) (118 . 47) +;; (119 . 48) (120 . 49) (121 . 50) (122 . 51) ( 48 . 52) ( 49 . 53) +;; ( 50 . 54) ( 51 . 55) ( 52 . 56) ( 53 . 57) ( 54 . 58) ( 55 . 59) +;; ( 56 . 60) ( 57 . 61) ( 43 . 62) ( 47 . 63) +;; )) +;; +;;(defvar vm-mime-base64-alphabet-decoding-vector +;; (let ((v (make-vector 123 nil)) +;; (p vm-mime-base64-alphabet-decoding-alist)) +;; (while p +;; (aset v (car (car p)) (cdr (car p))) +;; (setq p (cdr p))) +;; v )) + +(defvar vm-message-garbage-alist nil) +(make-variable-buffer-local 'vm-message-garbage-alist) +(defvar vm-folder-garbage-alist nil) +(make-variable-buffer-local 'vm-folder-garbage-alist) +(defconst vm-mime-header-list '("MIME-Version:" "Content-")) +(defconst vm-mime-xemacs-mule-charset-alist + '( + ("us-ascii" no-conversion) + ("iso-8859-1" no-conversion) + ("iso-8859-2" iso-8859-2) + ("iso-8859-3" iso-8859-3) + ("iso-8859-4" iso-8859-4) + ("iso-8859-5" iso-8859-5) + ("iso-8859-6" iso-8859-6) + ("iso-8859-7" iso-8859-7) + ("iso-8859-8" iso-8859-8) + ("iso-8859-9" iso-8859-9) + ("iso-2022-jp" iso-2022-jp) + ;; probably not correct, but probably better than nothing. + ("iso-2022-jp-2" iso-2022-jp) + ("iso-2022-int-1" iso-2022-int-1) + ("iso-2022-kr" iso-2022-kr) + ("euc-kr" iso-2022-kr) + )) +(defconst vm-mime-charset-completion-alist + '( + ("us-ascii") + ("iso-8859-1") + ("iso-8859-2") + ("iso-8859-3") + ("iso-8859-4") + ("iso-8859-5") + ("iso-8859-6") + ("iso-8859-7") + ("iso-8859-8") + ("iso-8859-9") + ("iso-2022-jp") + ("iso-2022-jp-2") + ("iso-2022-int-1") + ("iso-2022-kr") + )) +(defconst vm-mime-type-completion-alist + '( + ("text/plain") + ("text/enriched") + ("text/html") + ("audio/basic") + ("image/jpeg") + ("image/png") + ("image/gif") + ("image/tiff") + ("video/mpeg") + ("application/postscript") + ("application/octet-stream") + ("message/rfc822") + )) +(defconst vm-mime-encoded-word-regexp + "=\\?\\([^?]+\\)\\?\\([BQ]\\)\\?\\([^?]+\\)\\?=") +;; for MS-DOS and Windows NT +;; nil value means text file +;; t value means binary file +;; presumably it controls whether LF -> CRLF mapping is done +;; when writing to files. +(defvar buffer-file-type) +(defvar vm-frame-list nil) +(if (not (boundp 'shell-command-switch)) + (defvar shell-command-switch "-c")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-version.el --- a/lisp/vm/vm-version.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-version.el Mon Aug 13 09:13:56 2007 +0200 @@ -2,7 +2,7 @@ (provide 'vm-version) -(defconst vm-version "5.97" +(defconst vm-version "6.13" "Version number of VM.") (defun vm-version () diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-virtual.el --- a/lisp/vm/vm-virtual.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-virtual.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Virtual folders for VM -;;; Copyright (C) 1990, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1990-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -165,8 +165,7 @@ (vm-buffer-of (vm-real-message-of (car mp)))) - (apply 'vm-vs-or (vm-real-message-of (car mp)) - selectors)) + (apply 'vm-vs-or (car mp) selectors)) (apply 'vm-vs-or (car mp) selectors))) (progn (intern @@ -221,12 +220,18 @@ ;; ;; Now we tie it all together, with this section of code being ;; uninterruptible. - (let ((inhibit-quit t)) + (let ((inhibit-quit t) + (label-obarray vm-label-obarray)) (if (null vm-real-buffers) (setq vm-real-buffers real-buffers-used)) (save-excursion (while real-buffers-used (set-buffer (car real-buffers-used)) + ;; inherit the global label lists of all the associated + ;; real folders. + (mapatoms (function (lambda (x) (intern (symbol-name x) + label-obarray))) + vm-label-obarray) (if (not (memq vbuffer vm-virtual-buffers)) (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))) (setq real-buffers-used (cdr real-buffers-used)))) @@ -352,15 +357,6 @@ (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help)) (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror")) -(defun vm-delete-directory-file-names (list) - (vm-delete 'file-directory-p list)) - -(defun vm-delete-backup-file-names (list) - (vm-delete 'backup-file-name-p list)) - -(defun vm-delete-auto-save-file-names (list) - (vm-delete 'auto-save-file-name-p list)) - (defun vm-vs-or (m &rest selectors) (let ((result nil) selector arglist) (while selectors @@ -407,8 +403,8 @@ (save-excursion (save-restriction (widen) - (goto-char (vm-headers-of m)) - (re-search-forward arg (vm-text-of m) t)))) + (goto-char (vm-headers-of (vm-real-message-of m))) + (re-search-forward arg (vm-text-of (vm-real-message-of m)) t)))) (defun vm-vs-label (m arg) (vm-member arg (vm-labels-of m))) @@ -417,8 +413,8 @@ (save-excursion (save-restriction (widen) - (goto-char (vm-text-of m)) - (re-search-forward arg (vm-text-end-of m) t)))) + (goto-char (vm-text-of (vm-real-message-of m))) + (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t)))) (defun vm-vs-more-chars-than (m arg) (> (string-to-int (vm-su-byte-count m)) arg)) @@ -485,6 +481,8 @@ vm-label-obarray) nil))))) (t (setq arg (read-string prompt)))))) + (or (fboundp (intern (concat "vm-vs-" (symbol-name selector)))) + (error "Invalid selector")) (list selector arg))) ;; clear away links between real and virtual folders when @@ -536,22 +534,26 @@ (setq vm-real-buffers (delq b vm-real-buffers)) ;; set the message pointer to a new value if it is ;; now invalid. - (setq vmp vm-message-pointer) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (cdr vm-message-pointer))) - ;; if there were no good messages ahead, try going - ;; backward. - (if (null vm-message-pointer) - (progn - (setq vm-message-pointer vmp) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (vm-reverse-link-of (car vm-message-pointer)))))) + (cond + ((equal "Q" (vm-message-id-number-of (car vm-message-pointer))) + (vm-garbage-collect-message) + (setq vmp vm-message-pointer) + (while (and vm-message-pointer + (equal "Q" (vm-message-id-number-of + (car vm-message-pointer)))) + (setq vm-message-pointer + (cdr vm-message-pointer))) + ;; if there were no good messages ahead, try going + ;; backward. + (if (null vm-message-pointer) + (progn + (setq vm-message-pointer vmp) + (while (and vm-message-pointer + (equal "Q" (vm-message-id-number-of + (car vm-message-pointer)))) + (setq vm-message-pointer + (vm-reverse-link-of + (car vm-message-pointer)))))))) ;; expunge the virtual messages associated with ;; real messages that are going away. (setq vm-message-list diff -r 498bf5da1c90 -r 0d2f883870bc lisp/vm/vm-window.el --- a/lisp/vm/vm-window.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/vm/vm-window.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,5 @@ ;;; Window management code for VM -;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; Copyright (C) 1989-1997 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -17,7 +17,8 @@ (provide 'vm-window) -(defun vm-display (buffer display commands configs) +(defun vm-display (buffer display commands configs + &optional do-not-raise) ;; the clearinghouse VM display function. ;; ;; First arg BUFFER non-nil is a buffer to display or undisplay. @@ -62,11 +63,13 @@ ;; configuration is done, and only then if the value of ;; this-command is found in the COMMANDS list. (vm-save-buffer-excursion - (let ((w (and buffer (vm-get-buffer-window buffer)))) + (let* ((w (and buffer (vm-get-buffer-window buffer))) + (wf (and w (vm-window-frame w)))) (and buffer (set-buffer buffer)) - (and w display (vm-raise-frame (vm-window-frame w))) - (and w display (not (eq (vm-selected-frame) (vm-window-frame w))) - (vm-select-frame (vm-window-frame w))) + (if (and w display (not do-not-raise)) + (vm-raise-frame wf)) + (if (and w display (not (eq (vm-selected-frame) wf))) + (vm-select-frame wf)) (cond ((and buffer display) (if (and vm-display-buffer-hook (null (vm-get-visible-buffer-window buffer))) @@ -155,12 +158,16 @@ (setq message vm-mail-buffer))) ((eq major-mode 'vm-mode) (setq message (current-buffer))) + ((eq major-mode 'vm-presentation-mode) + (setq message vm-mail-buffer)) ((eq major-mode 'vm-virtual-mode) (setq message (current-buffer))) ((eq major-mode 'mail-mode) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) - (setq message vm-mail-buffer))) + (setq message vm-mail-buffer + ;; assume that the proximity implies affinity + composition (current-buffer)))) ((eq vm-system-state 'editing) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) @@ -169,6 +176,9 @@ ;; not in a VM related buffer, bail... (t (throw 'done nil))) (set-buffer message) + (vm-check-for-killed-presentation) + (if vm-presentation-buffer + (setq message vm-presentation-buffer)) ;; if this configuration is already the current one, don't ;; set it up again. (if (or (and vm-mutable-frames (eq (car config) vm-window-configuration)) @@ -395,7 +405,8 @@ (progn (condition-case nil (progn - (vm-delete-frame delete-me) + (if (vm-created-this-frame-p delete-me) + (vm-delete-frame delete-me)) (if (eq delete-me start) (setq start nil))) (error nil)) @@ -473,21 +484,31 @@ (defun vm-set-hooks-for-frame-deletion () (make-local-variable 'vm-undisplay-buffer-hook) - (make-local-variable 'kill-buffer-hook) (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) +(defun vm-created-this-frame-p (&optional frame) + (memq (or frame (vm-selected-frame)) vm-frame-list)) + (defun vm-delete-buffer-frame () - (save-excursion - (let ((w (vm-get-visible-buffer-window (current-buffer))) - (b (current-buffer))) - (and w (eq (vm-selected-frame) (vm-window-frame w)) - (vm-error-free-call 'vm-delete-frame (vm-window-frame w))) - (and w (let ((vm-mutable-frames t)) - (vm-delete-windows-or-frames-on b))))) - ;; do it only once - (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) - (remove-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) + ;; kludge. we only want to this to run on VM related buffers + ;; but this function is generally on a global hook. Check for + ;; vm-undisplay-buffer-hook set; this is a good sign that this + ;; is a VM buffer. + (if vm-undisplay-buffer-hook + (save-excursion + ;; run once only per buffer. + (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) + (let* ((w (vm-get-visible-buffer-window (current-buffer))) + (b (current-buffer)) + (wf (and w (vm-window-frame w)))) + (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf) + (vm-error-free-call 'vm-delete-frame wf)) + (and w (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on b))))))) + +(defun vm-register-frame (frame) + (setq vm-frame-list (cons frame vm-frame-list))) (defun vm-goto-new-frame (&rest types) (let ((params nil)) @@ -503,9 +524,42 @@ (select-screen (make-screen params))) ((fboundp 'new-screen) (select-screen (new-screen params)))) + (vm-register-frame (vm-selected-frame)) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-selected-frame))))) +(defun vm-goto-new-summary-frame-maybe () + (if (and vm-frame-per-summary (vm-multiple-frames-possible-p)) + (let ((w (vm-get-buffer-window vm-summary-buffer))) + (if (null w) + (progn + (vm-goto-new-frame 'summary) + (vm-set-hooks-for-frame-deletion)) + (save-excursion + (select-window w) + (and vm-warp-mouse-to-new-frame + (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) + +(defun vm-goto-new-folder-frame-maybe (&rest types) + (if (and vm-frame-per-folder (vm-multiple-frames-possible-p)) + (let ((w (or (vm-get-buffer-window (current-buffer)) + ;; summary == folder for the purpose + ;; of frame reuse. + (and vm-summary-buffer + (vm-get-buffer-window vm-summary-buffer)) + ;; presentation == folder for the purpose + ;; of frame reuse. + (and vm-presentation-buffer + (vm-get-buffer-window vm-presentation-buffer))))) + (if (null w) + (progn + (apply 'vm-goto-new-frame types) + (vm-set-hooks-for-frame-deletion)) + (save-excursion + (select-window w) + (and vm-warp-mouse-to-new-frame + (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) + (defun vm-warp-mouse-to-frame-maybe (&optional frame) (or frame (setq frame (vm-selected-frame))) (if (vm-mouse-support-possible-p) @@ -577,6 +631,22 @@ ((fboundp 'screen-visible-p) 'screen-visible-p) (t 'ignore)))) +(if (fboundp 'frame-iconified-p) + (fset 'vm-frame-iconified-p 'frame-iconified-p) + (defun vm-frame-iconified-p (&optional frame) + (eq (vm-frame-visible-p frame) 'icon))) + +;; frame-totally-visible-p is broken under XEmacs 19.14 and is +;; absent under Emacs 19.34. So vm-frame-per-summary won't work +;; quite right under these Emacs versions. XEmacs 19.15 should +;; have a working version of this function. +(if (and (fboundp 'frame-totally-visible-p) + (vm-xemacs-p) + (or (>= emacs-major-version 20) + (>= emacs-minor-version 15))) + (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p) + (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p)) + (fset 'vm-window-frame (symbol-function (cond ((fboundp 'window-frame) 'window-frame) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,5 +1,275 @@ +Fri Feb 14 09:34:35 1997 William M. Perry + +* w3.txi: Lots of documentation about stylesheets, chapter layout + changes. + +Thu Feb 13 07:01:59 1997 William M. Perry + +* Synch'd up to widget 1.38 + +* w3-forms.el (w3-form-resurrect-widgets): For now, don't use the nice new + GUI pushbuttons - they appear to suffer badly on long lines. + +* w3-mouse.el (w3-running-FSF19): Use new w3-popup-menu-on-mouse-3 variable + +* w3-vars.el: Removed _lots_ of obsolete variables +(w3-popup-menu-on-mouse-3): New variable to control whether W3 should + override mouse-3 or not. + +* Emacs-W3 3.0.58 released + +* w3.txi: Added stubs for stylesheet chapters and supported URLs + +* images.el (image-register-netpbm-utilities): This is now safe to call + multiple times again. + +Wed Feb 12 06:26:55 1997 William M. Perry + +* w3-forms.el (w3-form-keymap): When binding widget-end-of-line, make sure + that we do not overwrite Emacspeak's prefix-key. Now does a + where-is-internal to find the correct binding in global-map to + override. + +* w3-display.el (w3-display-node): bind :emacspeak-help to 'w3-widget-echo + in all the hypertext links. + +* w3-vars.el (w3-mode-map): New binding for \M-\t - this _should_ have + been taken care of by the [(meta tab)] definition, but evidently it + doesn't. *sigh* + +Tue Feb 11 07:33:50 1997 William M. Perry + +* w3-forms.el (w3-form-create-option-list): Specify :menu-tag-get so that + keyboard-based-completion doesn't get confused by the fact that some + items will have spaces slapped in at the end. + +* ssl.el (ssl-program-arguments): New variable - a list of command line + switches to send to the SSL program in a subprocess, before the hostname + and port number. + (open-ssl-stream): Use it. + +Mon Feb 10 07:45:31 1997 William M. Perry + +* url-file.el (url-file): Removed refs to variable url-use-hypertext-dired + +* url-vars.el: Removed obsolete variable url-use-hypertext-dired + +* url-file.el (url-dired-find-file-mouse): fixed bad typo of + (interactive...) spec, added documentation to a few functions. + (url-file): Removed refs to obsolete variable url-use-hypertext-dired + +* w3-xemac.el (w3-setup-version-specifics): Workaround for users of XEmacs + 19.14 or 20.0 with the bad bad bad lossage with text properties that + have null values. This bug is fixed in XEmacs 19.15, and will be in + 20.1 as well. This bug would cause you to get errors like: + internal error: no text-prop <#extent ....> start-open + +* w3.el (w3-widget-button-click): Deal with new image capabilities of the + widget checkbox/radio-button stuff. + +* Synch'ed up to widget 1.31 + +Sun Feb 9 15:39:19 1997 William M. Perry + +* Emacs-W3 3.0.57 released + +* url-file.el (url-dired-minor-mode): New minor mode that overrides a few + of direds keybindings to use Emacs-W3 instead of straight find-file. + (url-format-directory): Now just uses dired to display directory + listings, much more powerful than the old way. Can copy files, act on + multiple files, you all know the drill. + +* w3.txi: Added more chapters, reorg of others. + +* w3-display.el (w3-maybe-start-image-download): Fixed handling of bad + images in the cache again. Duh. + No longer log to the warnings buffer if we fail to load an image. Just + use message - much less intrusive. We just usually don't care that much + about failed image loads. + +* url-gw.el (url-open-stream): fixed typo - was calling old + url-nslookup-host instead of url-gateway-nslookup-host + +* w3.el (w3-insert-formatted-url): Now inserts markup in lowercase. + +Sat Feb 8 13:54:43 1997 William M. Perry + +* Emacs-W3 3.0.56 released. Getting closer! + +* w3-forms.el (w3-form-summarize-radio-button): Finally, a decent + summarization of radio buttons + Fixed typo in specifying summarizer for hidden form fields. + (w3-form-keymap): Bind C-a and C-e by default. + +* w3-widget.el (widget-image-value-create): When using emacspeak, show + client side imagemaps as a table. Need a more general solution for + this, but this makes us nicer than IE again. :) + +* Updated to widget 1.30 + +Fri Feb 7 16:49:55 1997 William M. Perry + +* w3-display.el (w3-handle-string-content): Make sure faces text + properties are closed, so that things don't bleed over. + (w3-fixup-eol-faces): New function for Emacs 19 that removes face + information at newlines, so that underlining will not extend from the + end of a line to the window edges - very ugly. + +* w3-menu.el (w3-menu-initialize-w3-mode-menu-map): Don't support 'emacs + in w3-use-menus under Emacs in Windows 95/NT. + +* w3-display.el (w3-finalize-image-download): Deal with bad images better. + (w3-finish-drawing): Better protection of putting images in. + +* url-gw.el (url-open-stream): Don't auto-retry connections. Don't throw + an error if you fail to connect to a site. This is for image loadings + that fail for some reason or another. + +* css.el (css-expand-length): better handling of float values and 'ex' + unit type. + +* font.el (x-font-create-object): Unconditionally make case-fold-search + non-nil so that we don't lose big-time. This was the cause of the very + weird font-spatial-to-canonical lossage under XEmacs with font sizes of + something like '+12pt' + +* w3.el (w3-view-this-url): Use widget-echo-help if we didn't find a URL + under point. + +Fri Feb 7 15:22:25 1997 Charles Levert + +* w3-widget.el (widget-image-notify): Bad data being fed to w3-fetch if a + client-side imagemap had an alt attribute (but only if the came + _after_ the use. + +Fri Feb 7 15:22:25 1997 William M. Perry + +* font.el (font-spatial-to-canonical): protect against bad input to this + function. + +Fri Feb 7 15:19:36 1997 Toby Speight + +* w3-parse.el (w3-parse-buffer): Parser didn't allow for the fact that + TAGC is optional on end-tags as well as on start-tags (i.e. " + bold-italic" is legal). + +Fri Feb 7 06:28:37 1997 William M. Perry + +* w3-forms.el (w3-form-keymap): Now inherits from widget-keymap, with a + few exceptions. + +* url.el (url-uncompress): This function now no longer looks at the file + extension to determine a compression/encoding method. This is so that + doing searches on `foo.tar.gz' will not bogusly cause the decompression + steps to run. Ick! + +* url-file.el (url-insert-possibly-compressed-file): This function no + longer atempts to decompress the file after loading it in. Instead, it + sets an appropriate content-transfer-encoding header based on the + filename, so that this will allow url-uncompress to work correctly on the + buffer. + +Thu Feb 6 06:24:26 1997 William M. Perry + +* w3-print.el (w3-postscript-print-function): New variable to control what + function is used to generate postscript output. + (w3-print-this-url): Use it. + +* w3-display.el (w3-handle-string-content): Make all inserted text + read-only + +* w3-forms.el (w3-form-use-old-style): New variable to control whether to + use the old-style interaction with form fields instead of the 'type + directly into the buffer' method + (w3-form-determine-size): Use it. + (w3-form-create-integer): Use it. + (w3-form-create-float): Use it. + (w3-form-create-text): Use it. + (w3-form-create-password): Use it. + (w3-revert-form): Fixed error with 'reset' buttons on forms that had + hidden form fields. + +* w3-vars.el (w3-mode-map): Define [backtab] by default + +* w3-display.el (w3-size-of-tree): Removed some warnings +(w3-display-table-dimensions): ditto + +* Updated to widget 1.26 + +* default.css: Some default formatting changes for input fields. + Everything is underlined by default except submit/reset/image/button + fields, so that they are a little easier to spot. + +* w3-parse.el (w3-parse-buffer): Now slaps pseudo-elements into input + fields so that stylesheets can access them. + +Wed Feb 5 14:42:12 1997 William M. Perry + +* Updated to widget 1.24 + +* Happy birthday Jenny P. + +Tue Feb 4 08:21:03 1997 William M. Perry + +* font.el (x-font-create-name): Better checking/optimizing of when to just + return the default font. + +* w3-forms.el: Make use of the new information, and pass it down to the + widget library appropriately. + +* w3-display.el (w3-display-node): Now passes in the entire list of active + faces to form creation functions. + +Mon Feb 3 07:26:18 1997 William M. Perry + +* w3-emulate.el (w3-lynx-emulation-minor-mode-map): Lots of new + keybindings for lynx emulation minor mode. + +* Emacs-W3 3.0.55 released + +* w3-forms.el (w3-form-determine-size): Fixed _STUPID_ problem where + option lists would lose everything but the first option in them. I'm a + dumbass. Sort modifies its list parameter! ICK ICK ICK. + +* url.el (url-after-change-function): Show prettier status messages. + Sizes are converted to bytes, k, or M, depending on how big the file + is. + +* w3.txi: Lots of documentation changes - volunteers welcome. + +* Removed personal annotation support, since it wasn't shown with the new + display engine, it needs to be rethought, and nobody had complained in + the entire beta cycle. + +* w3.el (w3-history-find-url-internal): Redid the history mechanism. + Toolbar and menu entries are now grayed out appropriately. + +* url-http.el (url-create-mime-request): Fixed cookie support if not going + through a proxy gateway. + +Sun Feb 2 22:05:41 1997 William M. Perry + +* w3-display.el (w3-display-table): Fix for negative colwidth + +Fri Jan 31 14:28:54 1997 William M. Perry + +* w3.el (w3-fetch): Fixed targetted links (http://blah/#foo) + +Fri Jan 31 11:20:47 1997 Alf-Ivar Holm + +* w3.el (w3-mail-current-document): Fixed problem with calling + w3-parse-buffer with too many arguments when mailing LaTeX-ified + files. + +Fri Jan 31 11:19:37 1997 Cord Kielhorn + +* css.el (css-expand-length): Fixed bad regexps for percentage and + character based lengths + Thu Jan 30 20:27:06 1997 William M. Perry +* Emacs-W3 3.0.52 released + * w3-display.el (w3-handle-image): When doing table auto layout, don't start loading the images. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/Makefile --- a/lisp/w3/Makefile Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/Makefile Mon Aug 13 09:13:56 2007 +0200 @@ -38,7 +38,7 @@ url-pgp.el url-vars.el url-wais.el url-auth.el mm.el md5.el \ url-gw.el ssl.el base64.el url.el socks.el -CUSTOMSOURCES = widget.el widget-edit.el +CUSTOMSOURCES = # widget.el widget-edit.el CUSTOMOBJECTS = $(CUSTOMSOURCES:.el=.elc) URLOBJECTS = $(URLSOURCES:.el=.elc) @@ -46,9 +46,9 @@ $(CUSTOMSOURCES) $(URLSOURCES) mule-sysdp.el w3-widget.el \ w3-imap.el css.el dsssl.el font.el images.el w3-vars.el \ w3-style.el w3-keyword.el w3-forms.el w3-emulate.el \ - w3-annotat.el w3-auto.el w3-menu.el w3-mouse.el w3-toolbar.el \ - w3-prefs.el w3-speak.el w3-latex.el w3-parse.el w3-display.el \ - w3-print.el w3-about.el w3-hot.el w3-e19.el w3-xemac.el w3.el + w3-auto.el w3-menu.el w3-mouse.el w3-toolbar.el w3-prefs.el \ + w3-speak.el w3-latex.el w3-parse.el w3-display.el w3-print.el \ + w3-about.el w3-hot.el w3-e19.el w3-xemac.el w3.el OBJECTS = $(SOURCES:.el=.elc) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/css.el --- a/lisp/w3/css.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/css.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; css.el -- Cascading Style Sheet parser ;; Author: wmperry -;; Created: 1997/01/17 14:30:54 -;; Version: 1.25 +;; Created: 1997/02/08 05:24:49 +;; Version: 1.27 ;; Keywords: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -366,10 +366,10 @@ (cond ((not (stringp spec)) spec) ((string-equal spec "auto") nil) - ((string-match "\([0-9]+\)%" spec) ; A percentage + ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)%" spec) ; A percentage nil) - ((string-match "\([0-9]+\)e[mn]" spec) ; Character based - (string-to-int (substring spec (match-beginning 1) (match-end 1)))) + ((string-match "\\([+-]?\\([0-9]+\\|[0-9]*\\.[0-9]+\\)\\)e[mx]" spec) ; Character based + (max 0 (round (string-to-number (match-string 1 spec))))) (t (truncate (font-spatial-to-canonical spec))) ) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/docomp.el --- a/lisp/w3/docomp.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/docomp.el Mon Aug 13 09:13:56 2007 +0200 @@ -78,9 +78,6 @@ 'gnus-nntp-server 'nntp-server-name 'nntp-version 'gnus-default-nntp-server) -;; For ps-print -(w3-declare-variables 'ps-bold-faces 'ps-italic-faces 'ps-print-version) - ;; For xpm-button (w3-declare-variables 'x-library-search-path) @@ -108,5 +105,6 @@ (and w3-running-FSF19 (< emacs-minor-version 29) (require 'font)) + (require 'w3-sysdp) (provide 'ange-ftp) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/font.el --- a/lisp/w3/font.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/font.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; font.el --- New font model ;; Author: wmperry -;; Created: 1997/01/30 00:58:33 -;; Version: 1.29 +;; Created: 1997/02/08 00:56:14 +;; Version: 1.33 ;; Keywords: faces ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -29,9 +29,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The emacsen compatibility package - load it up before anything else ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'cl) + (eval-and-compile - (require 'w3-sysdp) - (require 'cl)) + (if (not (and (string-match "XEmacs" emacs-version) + (or (> emacs-major-version 19) + (>= emacs-minor-version 14)))) + (require 'w3-sysdp))) (require 'disp-table) (if (not (fboundp '<<)) (fset '<< 'lsh)) @@ -295,8 +299,12 @@ (defun font-spatial-to-canonical (spec &optional device) "Convert SPEC (in inches, millimeters, points, or picas) into points" ;; 1 in = 6 pa = 25.4 mm = 72 pt - (if (numberp spec) - spec + (cond + ((numberp spec) + spec) + ((null spec) + nil) + (t (let ((num nil) (type nil) ;; If for any reason we get null for any of this, default @@ -339,7 +347,7 @@ (t (setq retval num)) ) - retval))) + retval)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -466,46 +474,47 @@ )))) (defun x-font-create-object (fontname &optional device) - (if (or (not (stringp fontname)) - (not (string-match font-x-font-regexp fontname))) - (make-font) - (let ((family nil) - (style nil) - (size nil) - (weight (match-string 1 fontname)) - (slant (match-string 2 fontname)) - (swidth (match-string 3 fontname)) - (adstyle (match-string 4 fontname)) - (pxsize (match-string 5 fontname)) - (ptsize (match-string 6 fontname)) - (retval nil) - (case-fold-search t) - ) - (if (not (string-match x-font-regexp-foundry-and-family fontname)) - nil - (setq family (list (downcase (match-string 1 fontname))))) - (if (string= "*" weight) (setq weight nil)) - (if (string= "*" slant) (setq slant nil)) - (if (string= "*" swidth) (setq swidth nil)) - (if (string= "*" adstyle) (setq adstyle nil)) - (if (string= "*" pxsize) (setq pxsize nil)) - (if (string= "*" ptsize) (setq ptsize nil)) - (if ptsize (setq size (/ (string-to-int ptsize) 10))) - (if (and (not size) pxsize) (setq size (concat pxsize "px"))) - (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) - (if (and adstyle (not (equal adstyle ""))) - (setq family (append family (list (downcase adstyle))))) - (setq retval (make-font :family family - :weight weight - :size size)) - (set-font-bold-p retval (eq :bold weight)) - (cond - ((null slant) nil) - ((member slant '("i" "I")) - (set-font-italic-p retval t)) - ((member slant '("o" "O")) - (set-font-oblique-p retval t))) - retval))) + (let ((case-fold-search t)) + (if (or (not (stringp fontname)) + (not (string-match font-x-font-regexp fontname))) + (make-font) + (let ((family nil) + (style nil) + (size nil) + (weight (match-string 1 fontname)) + (slant (match-string 2 fontname)) + (swidth (match-string 3 fontname)) + (adstyle (match-string 4 fontname)) + (pxsize (match-string 5 fontname)) + (ptsize (match-string 6 fontname)) + (retval nil) + (case-fold-search t) + ) + (if (not (string-match x-font-regexp-foundry-and-family fontname)) + nil + (setq family (list (downcase (match-string 1 fontname))))) + (if (string= "*" weight) (setq weight nil)) + (if (string= "*" slant) (setq slant nil)) + (if (string= "*" swidth) (setq swidth nil)) + (if (string= "*" adstyle) (setq adstyle nil)) + (if (string= "*" pxsize) (setq pxsize nil)) + (if (string= "*" ptsize) (setq ptsize nil)) + (if ptsize (setq size (/ (string-to-int ptsize) 10))) + (if (and (not size) pxsize) (setq size (concat pxsize "px"))) + (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) + (if (and adstyle (not (equal adstyle ""))) + (setq family (append family (list (downcase adstyle))))) + (setq retval (make-font :family family + :weight weight + :size size)) + (set-font-bold-p retval (eq :bold weight)) + (cond + ((null slant) nil) + ((member slant '("i" "I")) + (set-font-italic-p retval t)) + ((member slant '("o" "O")) + (set-font-oblique-p retval t))) + retval)))) (defun x-font-families-for-device (&optional device no-resetp) (condition-case () @@ -565,9 +574,7 @@ (font-size fontobj) (font-registry fontobj) (font-encoding fontobj))) - (not (font-bold-p fontobj)) - (not (font-italic-p fontobj)) - (not (font-oblique-p fontobj))) + (= (font-style fontobj) 0)) (face-font 'default) (or device (setq device (selected-device))) (let ((family (or (font-family fontobj) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/images.el --- a/lisp/w3/images.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/images.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; images.el --- Automatic image converters ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.6 +;; Created: 1997/02/13 15:01:57 +;; Version: 1.8 ;; Keywords: images ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,7 +30,10 @@ ;;; The emacsen compatibility package - load it up before anything else ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-and-compile - (require 'w3-sysdp)) + (if (not (and (string-match "XEmacs" emacs-version) + (or (> emacs-major-version 19) + (>= emacs-minor-version 14)))) + (require 'w3-sysdp))) (defvar image-temp-stack nil "Do no touch - internal storage.") (defvar image-converters nil "Storage for the image converters.") @@ -164,7 +167,7 @@ (defun image-register-netpbm-utilities () "Register all the netpbm utility packages converters." (interactive) - (if (image-converter-registered-p 'xpm 'gif) + (if (image-converter-registered-p 'pgm 'pbm) nil (image-register-converter 'pgm 'pbm "pgmtopbm") (image-register-converter 'ppm 'pgm "ppmtopgm") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/ssl.el --- a/lisp/w3/ssl.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/ssl.el Mon Aug 13 09:13:56 2007 +0200 @@ -26,10 +26,13 @@ ;;; Boston, MA 02111-1307, USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ssl-program-name "ssl %s %s" - "*The program to run in a subprocess to open an SSL connection. -This is run through `format' with two strings, the hostname and port # -to connect to.") +(defvar ssl-program-name "ssl" + "*The program to run in a subprocess to open an SSL connection.") + +(defvar ssl-program-arguments nil + "*Arguments that should be passed to the program `ssl-program-name'. +This should be used if your SSL program needs command line switches to +specify any behaviour (certificate file locations, etc).") (defun open-ssl-stream (name buffer host service) "Open a SSL connection for a service to a host. @@ -45,13 +48,15 @@ Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to." - (let ((proc (start-process name buffer - "/bin/sh" - "-c" - (format ssl-program-name host - (if (stringp service) - service - (int-to-string service)))))) + (let ((proc (apply 'start-process + name + buffer + ssl-program-name + (append ssl-program-arguments + (list host + (if (stringp service) + service + (int-to-string service))))))) (process-kill-without-query proc) proc)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-file.el --- a/lisp/w3/url-file.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-file.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-file.el --- File retrieval code ;; Author: wmperry -;; Created: 1997/01/24 14:32:50 -;; Version: 1.9 +;; Created: 1997/02/10 16:16:46 +;; Version: 1.13 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -44,136 +44,174 @@ (coding-system-for-read mule-no-coding-system)) (setq compressed (cond - ((file-exists-p fname) nil) + ((file-exists-p fname) + (if (string-match "\\.\\(z\\|gz\\|Z\\)$" fname) + (case (intern (match-string 1 fname)) + ((z gz) + (setq url-current-mime-headers (cons + (cons + "content-transfer-encoding" + "gzip") + url-current-mime-headers))) + (Z + (setq url-current-mime-headers (cons + (cons + "content-transfer-encoding" + "compress") + url-current-mime-headers)))) + nil)) ((file-exists-p (concat fname ".Z")) - (setq fname (concat fname ".Z"))) + (setq fname (concat fname ".Z") + url-current-mime-headers (cons (cons + "content-transfer-encoding" + "compress") + url-current-mime-headers))) ((file-exists-p (concat fname ".gz")) - (setq fname (concat fname ".gz"))) + (setq fname (concat fname ".gz") + url-current-mime-headers (cons (cons + "content-transfer-encoding" + "gzip") + url-current-mime-headers))) ((file-exists-p (concat fname ".z")) - (setq fname (concat fname ".z"))) + (setq fname (concat fname ".z") + url-current-mime-headers (cons (cons + "content-transfer-encoding" + "gzip") + url-current-mime-headers))) (t (error "File not found %s" fname)))) - (if (or (not compressed) url-inhibit-uncompression) - (apply 'insert-file-contents fname args) - (let* ((extn (url-file-extension fname)) - (code (cdr-safe (assoc extn url-uncompressor-alist))) - (decoder (cdr-safe (assoc code mm-content-transfer-encodings)))) - (cond - ((null decoder) - (apply 'insert-file-contents fname args)) - ((stringp decoder) - (apply 'insert-file-contents fname args) - (message "Decoding...") - (call-process-region (point-min) (point-max) decoder t t nil) - (message "Decoding... done.")) - ((listp decoder) - (apply 'call-process-region (point-min) (point-max) - (car decoder) t t t (cdr decoder))) - ((and (symbolp decoder) (fboundp decoder)) - (apply 'insert-file-contents fname args) - (message "Decoding...") - (funcall decoder (point-min) (point-max)) - (message "Decoding... done.")) - (t - (error "Malformed entry for %s in `mm-content-transfer-encodings'" - code)))))) - (set-buffer-modified-p nil)) + (apply 'insert-file-contents fname args) + (set-buffer-modified-p nil))) + +(defvar url-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'url-dired-find-file) + (if url-running-xemacs + (define-key map [button2] 'url-dired-find-file-mouse) + (define-key map [mouse-2] 'url-dired-find-file-mouse)) + map) + "Keymap used when browsing directories.") + +(defvar url-dired-minor-mode nil + "Whether we are in url-dired-minor-mode") + +(make-variable-buffer-local 'url-dired-minor-mode) + +(defun url-dired-find-file () + "In dired, visit the file or directory named on this line, using Emacs-W3." + (interactive) + (w3-open-local (dired-get-filename))) + +(defun url-dired-find-file-mouse (event) + "In dired, visit the file or directory name you click on, using Emacs-W3." + (interactive "@e") + (if (event-point event) + (progn + (goto-char (event-point event)) + (url-dired-find-file)))) + +(defun url-dired-minor-mode (&optional arg) + "Minor mode for directory browsing with Emacs-W3." + (interactive "P") + (cond + ((null arg) + (setq url-dired-minor-mode (not url-dired-minor-mode))) + ((equal 0 arg) + (setq url-dired-minor-mode nil)) + (t + (setq url-dired-minor-mode t)))) + +(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map) (defun url-format-directory (dir) ;; Format the files in DIR into hypertext - (let ((files (directory-files dir nil)) file - div attr mod-time size typ title) - (if (and url-directory-index-file - (file-exists-p (expand-file-name url-directory-index-file dir)) - (file-readable-p (expand-file-name url-directory-index-file dir))) - (save-excursion - (set-buffer url-working-buffer) - (erase-buffer) - (insert-file-contents-literally - (expand-file-name url-directory-index-file dir))) + (if (and url-directory-index-file + (file-exists-p (expand-file-name url-directory-index-file dir)) + (file-readable-p (expand-file-name url-directory-index-file dir))) (save-excursion - (if (string-match "/\\([^/]+\\)/$" dir) - (setq title (concat ".../" (url-match dir 1) "/")) - (setq title "/")) - (setq div (1- (length files))) (set-buffer url-working-buffer) (erase-buffer) - (insert "\n" - " \n" - " " title "\n" - " \n" - " \n" - "
    \n" - "

    Index of " title "

    \n" - " 
    \n"
-		"       Name                     Last modified                Size\n
    " - "
    \n 
    \n")
-	(while files
-	  (url-lazy-message "Building directory list... (%d%%)"
-			    (/ (* 100 (- div (length files))) div))
-	  (setq file (expand-file-name (car files) dir)
-		attr (file-attributes file)
-		file (car files)
-		mod-time (nth 5 attr)
-		size (nth 7 attr)
-		typ (or (mm-extension-to-mime (url-file-extension file)) ""))
-	  (setq file (url-hexify-string file))
-	  (if (equal '(0 0) mod-time) ; Set to null if unknown or
-	      (setq mod-time "Unknown                 ")
-	    (setq mod-time (current-time-string mod-time)))
-	  (if (or (equal size 0) (equal size -1) (null size))
-	      (setq size "   -")
-	    (setq size
-		  (cond
-		   ((< size 1024) (concat "   " "1K"))
-		   ((< size 1048576) (concat "   "
-					     (int-to-string
-					      (max 1 (/ size 1024))) "K"))
-		   (t
-		    (let* ((megs (max 1 (/ size 1048576)))
-			   (kilo (/ (- size (* megs 1048576)) 1024)))
-		      (concat "   "  (int-to-string megs)
-			      (if (> kilo 0)
-				  (concat "." (int-to-string kilo))
-				"") "M"))))))
-	  (cond
-	   ((or (equal "." (car files))
-		(equal "/.." (car files)))
-	    nil)
-	   ((equal ".." (car files))
-	    (if (not (= ?/ (aref file (1- (length file)))))
-		(setq file (concat file "/"))))
-	   ((stringp (nth 0 attr))	; Symbolic link handling
-	    (insert "[LNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((nth 0 attr)		; Directory handling
-	    (insert "[DIR] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "image" typ)
-	    (insert "[IMG] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "application" typ)
-	    (insert "[APP] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "text" typ)
-	    (insert "[TXT] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   (t
-	    (insert "[UNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n")))
-	  (setq files (cdr files)))
-	(insert "
    \n" - "
    \n" - " \n" - "\n" - "\n"))))) + (insert-file-contents-literally + (expand-file-name url-directory-index-file dir))) + (kill-buffer (current-buffer)) + (find-file dir) + (url-dired-minor-mode t))) +; (let ((files (directory-files dir nil)) file +; div attr mod-time size typ title desc) +; (save-excursion +; (if (string-match "/\\([^/]+\\)/$" dir) +; (setq title (concat ".../" (url-match dir 1) "/")) +; (setq title "/")) +; (setq div (1- (length files))) +; (set-buffer url-working-buffer) +; (erase-buffer) +; (insert "\n" +; " \n" +; " " title "\n" +; " \n" +; " \n" +; "

    Index of " title "

    \n" +; " \n" +; " \n" +; " \n") +; (while files +; (url-lazy-message "Building directory list... (%d%%)" +; (/ (* 100 (- div (length files))) div)) +; (setq file (expand-file-name (car files) dir) +; attr (file-attributes file) +; file (car files) +; mod-time (nth 5 attr) +; size (nth 7 attr) +; typ (or (mm-extension-to-mime (url-file-extension file)) "")) +; (setq file (url-hexify-string file)) +; (if (equal '(0 0) mod-time) ; Set to null if unknown or +; (setq mod-time "Unknown") +; (setq mod-time (current-time-string mod-time))) +; (if (or (equal size 0) (equal size -1) (null size)) +; (setq size "-") +; (setq size +; (cond +; ((< size 1024) "1K") +; ((< size 1048576) (concat (int-to-string +; (max 1 (/ size 1024))) "K")) +; (t +; (let* ((megs (max 1 (/ size 1048576))) +; (kilo (/ (- size (* megs 1048576)) 1024))) +; (concat (int-to-string megs) +; (if (> kilo 0) +; (concat "." (int-to-string kilo)) +; "") "M")))))) +; (cond +; ((or (equal "." (car files)) +; (equal "/.." (car files))) +; (setq desc nil)) +; ((equal ".." (car files)) +; (if (not (= ?/ (aref file (1- (length file))))) +; (setq file (concat file "/")))) +; ((stringp (nth 0 attr)) ; Symbolic link handling +; (setq desc "[LNK]")) +; ((nth 0 attr) ; Directory handling +; (setq desc "[DIR]")) +; ((string-match "image" typ) +; (setq desc "[IMG]")) +; ((string-match "application" typ) +; (setq desc "[APP]")) +; ((string-match "text" typ) +; (setq desc "[TXT]")) +; ((auto-save-file-name-p (car files)) +; (setq desc "[BAK]")) +; (t +; (setq desc "[UNK]"))) +; (if desc +; (insert "\n")) +; (setq files (cdr files))) +; (insert "
    NameLast ModifiedSize
    " desc " " (car files) +; "" mod-time "

    " size +; "

    \n" +; " \n" +; "\n" +; "\n"))) (defun url-host-is-local-p (host) "Return t iff HOST references our local machine." @@ -222,20 +260,14 @@ nil))) (cond ((file-directory-p filename) - (if url-use-hypertext-dired - (progn - (if (string-match "/$" filename) - nil - (setq filename (concat filename "/"))) - (if (string-match "/$" file) - nil - (setq file (concat file "/"))) - (url-set-filename urlobj file) - (url-format-directory filename)) - (progn - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (find-file filename)))) + (if (string-match "/$" filename) + nil + (setq filename (concat filename "/"))) + (if (string-match "/$" file) + nil + (setq file (concat file "/"))) + (url-set-filename urlobj file) + (url-format-directory filename)) ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk)) (cond ((file-exists-p filename) nil) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-gopher.el --- a/lisp/w3/url-gopher.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-gopher.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-gopher.el --- Gopher Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.4 +;; Created: 1997/02/08 05:25:58 +;; Version: 1.5 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -270,8 +270,8 @@ url-current-type "gopher") (if (> (length selector) 0) (setq selector (substring selector 1 nil))) - (if (stringp proc) - (message "%s" proc) + (if (not (processp proc)) + nil (save-excursion (process-send-string proc (concat selector "\r\n")) (while (and (or (not wait-for) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-gw.el --- a/lisp/w3/url-gw.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-gw.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-gw.el --- Gateway munging for URL loading ;; Author: wmperry -;; Created: 1997/01/16 14:17:34 -;; Version: 1.3 +;; Created: 1997/02/10 01:00:01 +;; Version: 1.5 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -188,7 +188,6 @@ (int-to-string service)))) ;; An attempt to deal with denied connections, and attempt to reconnect - (max-retries url-connection-retries) (cur-retries 0) (retry t) (errobj nil) @@ -196,46 +195,34 @@ ;; If the user told us to do DNS for them, do it. (if url-gateway-broken-resolution - (setq host (url-nslookup-host host))) + (setq host (url-gateway-nslookup-host host))) - (while (and (not conn) retry) - (condition-case errobj - (setq conn (case gw-method - (ssl - (open-ssl-stream name buffer host service)) - ((tcp native) - (and (eq 'tcp gw-method) (require 'tcp)) - (open-network-stream name buffer host service)) - (socks - (socks-open-network-stream name buffer host service)) - (telnet - (url-open-telnet name buffer host service)) - (rlogin - (url-open-rlogin name buffer host service)) - (otherwise - (error "Bad setting of url-gateway-method: %s" - url-gateway-method)))) - (error - (url-save-error errobj) - (save-window-excursion - (save-excursion - (switch-to-buffer-other-window " *url-error*") - (shrink-window-if-larger-than-buffer) - (goto-char (point-min)) - (if (and (re-search-forward "in use" nil t) - (< cur-retries max-retries)) - (progn - (setq retry t - cur-retries (1+ cur-retries)) - (sleep-for 0.5)) - (setq cur-retries 0 - retry (funcall url-confirmation-func - (concat "Connection to " host - " failed, retry? ")))) - (kill-buffer (current-buffer))))))) - (if (not conn) - (error "Unable to connect to %s:%s" host service) - (mule-inhibit-code-conversion conn) - conn))) + (condition-case errobj + (setq conn (case gw-method + (ssl + (open-ssl-stream name buffer host service)) + ((tcp native) + (and (eq 'tcp gw-method) (require 'tcp)) + (open-network-stream name buffer host service)) + (socks + (socks-open-network-stream name buffer host service)) + (telnet + (url-open-telnet name buffer host service)) + (rlogin + (url-open-rlogin name buffer host service)) + (otherwise + (error "Bad setting of url-gateway-method: %s" + url-gateway-method)))) + (error + (insert "Could not contact host: " host " / " + (if (stringp service) service (int-to-string service)) + "\nAttempted using gateway method: " + (symbol-name gw-method) + "\n---- Error was: ----\n") + (setq url-current-mime-headers '(("content-type" . "text/plain"))) + (display-error errobj (current-buffer)))) + (if conn + (mule-inhibit-code-conversion conn)) + conn)) (provide 'url-gw) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-http.el --- a/lisp/w3/url-http.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-http.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-http.el --- HTTP Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/01/26 03:56:59 -;; Version: 1.11 +;; Created: 1997/02/08 05:29:12 +;; Version: 1.13 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -133,7 +133,7 @@ (let ((url-basic-auth-storage url-proxy-basic-authentication)) (url-get-authentication url nil 'any nil)))) - (proxy-obj (if (boundp 'proxy-info) + (proxy-obj (if (and (boundp 'proxy-info) proxy-info) (url-generic-parse-url proxy-info))) (real-fname (if proxy-obj (url-filename proxy-obj) fname)) (host (or (and proxy-obj (url-host proxy-obj)) @@ -583,21 +583,8 @@ (let ((process (url-open-stream "WWW" url-working-buffer server (string-to-int port)))) - (if (stringp process) - (progn - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-mime-type "text/html" - url-current-mime-viewer - (mm-mime-info "text/html" nil 5)) - (insert "ERROR\n" - "

    ERROR - Could not establish connection

    " - "

    " - "The browser could not establish a connection " - (format "to %s:%s.

    " server port) - "The server is either down, or the URL" - (format "(%s) is malformed.

    " (url-view-url t))) - (message "%s" process)) + (if (not (processp process)) + nil (progn (url-process-put process 'url (or proxy-info url)) (process-kill-without-query process) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-misc.el --- a/lisp/w3/url-misc.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-misc.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-misc.el --- Misc Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/01/21 21:14:56 -;; Version: 1.9 +;; Created: 1997/02/08 05:29:22 +;; Version: 1.10 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -54,8 +54,8 @@ (user (url-unhex-string (url-filename urlobj))) (proc (url-open-stream "finger" url-working-buffer host (string-to-int port)))) - (if (stringp proc) - (message "%s" proc) + (if (not (processp proc)) + nil (process-kill-without-query proc) (if (= (string-to-char user) ?/) (setq user (substring user 1 nil))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url-vars.el --- a/lisp/w3/url-vars.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url-vars.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool ;; Author: wmperry -;; Created: 1997/01/16 14:13:05 -;; Version: 1.24 +;; Created: 1997/02/10 16:15:19 +;; Version: 1.27 ;; Keywords: comm, data, processes, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -273,7 +273,6 @@ (defvar url-working-buffer url-default-working-buffer " The buffer to do all of the processing in. (It defaults to `url-default-working-buffer' and is bound to ` *URL-*' buffers when used for multiple requests, cf. `url-multiple-p')") -(defvar url-current-annotation nil "URL of document we are annotating...") (defvar url-current-referer nil "Referer of this page.") (defvar url-current-content-length nil "Current content length.") (defvar url-current-file nil "Filename of current document.") @@ -427,12 +426,6 @@ single argument (the prompt), and returns t only if a positive answer is gotten.") -(defvar url-connection-retries 5 - "*# of times to try for a connection before bailing. -If for some reason url-open-stream cannot make a connection to a host -right away, it will sit for 1 second, then try again, up to this many -tries.") - (defvar url-find-this-link nil "Link to go to within a document.") (defvar url-gateway-method 'native @@ -454,19 +447,6 @@ (defvar url-running-xemacs (string-match "XEmacs" emacs-version) "*In XEmacs?.") -(defvar url-use-hypertext-dired t - "*How to format directory listings. - -If value is non-nil, use directory-files to list them out and -transform them into a hypertext document, then pass it through the -parse like any other document. - -If value nil, just pass the directory off to dired using find-file.") - -(defconst monthabbrev-alist - '(("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 url-default-ports '(("http" . "80") ("gopher" . "70") ("telnet" . "23") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/url.el --- a/lisp/w3/url.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/url.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,13 +1,13 @@ ;;; url.el --- Uniform Resource Locator retrieval tool ;; Author: wmperry -;; Created: 1997/01/29 14:32:36 -;; Version: 1.48 +;; Created: 1997/02/07 14:30:25 +;; Version: 1.51 ;; Keywords: comm, data, processes, hypermedia ;;; LCD Archive Entry: ;;; url|William M. Perry|wmperry@cs.indiana.edu| ;;; Functions for retrieving/manipulating URLs| -;;; 1997/01/29 14:32:36|1.48|Location Undetermined +;;; 1997/02/07 14:30:25|1.51|Location Undetermined ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -44,7 +44,11 @@ (require 'ange-ftp) (error nil))) -(require 'w3-sysdp) +(eval-and-compile + (if (not (and (string-match "XEmacs" emacs-version) + (or (> emacs-major-version 19) + (>= emacs-minor-version 14)))) + (require 'w3-sysdp))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions that might not exist in old versions of emacs @@ -277,6 +281,15 @@ (round (* 100 (/ x (float y)))) (/ (* x 100) y))) +(defun url-pretty-length (n) + (cond + ((< n 1024) + (format "%d bytes" n)) + ((< n (* 1024 1024)) + (format "%dk" (/ n 1024.0))) + (t + (format "%2.2fM" (/ n (* 1024 1024.0)))))) + (defun url-after-change-function (&rest args) ;; The nitty gritty details of messaging the HTTP/1.0 status messages ;; in the minibuffer." @@ -311,22 +324,25 @@ (cond ((and url-current-content-length (> url-current-content-length 1) url-current-mime-type) - (url-lazy-message "Reading [%s]... %d of %d bytes (%d%%)" + (url-lazy-message "Reading [%s]... %s of %s (%d%%)" url-current-mime-type - current-length - url-current-content-length + (url-pretty-length current-length) + (url-pretty-length url-current-content-length) (url-percentage current-length url-current-content-length))) ((and url-current-content-length (> url-current-content-length 1)) - (url-lazy-message "Reading... %d of %d bytes (%d%%)" - current-length url-current-content-length + (url-lazy-message "Reading... %s of %s (%d%%)" + (url-pretty-length current-length) + (url-pretty-length url-current-content-length) (url-percentage current-length url-current-content-length))) ((and (/= 1 current-length) url-current-mime-type) - (url-lazy-message "Reading [%s]... %d bytes" - url-current-mime-type current-length)) + (url-lazy-message "Reading [%s]... %s" + url-current-mime-type + (url-pretty-length current-length))) ((/= 1 current-length) - (url-lazy-message "Reading... %d bytes." current-length)) + (url-lazy-message "Reading... %s." + (url-pretty-length current-length))) (t (url-lazy-message "Waiting for response..."))))) (defun url-insert-entities-in-string (string) @@ -1527,8 +1543,6 @@ url-current-mime-headers))) (code-2 (cdr-safe (assoc "content-encoding" url-current-mime-headers))) - (code-3 (and (not code-1) (not code-2) - (cdr-safe (assoc extn url-uncompressor-alist)))) (done nil) (default-process-coding-system (cons mule-no-coding-system mule-no-coding-system))) @@ -1539,23 +1553,22 @@ (cdr-safe (assoc code mm-content-transfer-encodings))) done (cons code done)) - (cond - ((null decoder) nil) - ((stringp decoder) - (message "Decoding...") - (call-process-region (point-min) (point-max) decoder t t nil) - (message "Decoding... done.")) - ((listp decoder) - (apply 'call-process-region (point-min) (point-max) - (car decoder) t t nil (cdr decoder))) - ((and (symbolp decoder) (fboundp decoder)) - (message "Decoding...") - (funcall decoder (point-min) (point-max)) - (message "Decoding... done.")) - (t - (error "Bad entry for %s in `mm-content-transfer-encodings'" - code))))) - (list code-1 code-2 code-3)))) + (if (not decoder) + nil + (message "Decoding (%s)..." code) + (cond + ((stringp decoder) + (call-process-region (point-min) (point-max) decoder t t nil)) + ((listp decoder) + (apply 'call-process-region (point-min) (point-max) + (car decoder) t t nil (cdr decoder))) + ((and (symbolp decoder) (fboundp decoder)) + (funcall decoder (point-min) (point-max))) + (t + (error "Bad entry for %s in `mm-content-transfer-encodings'" + code))) + (message "Decoding (%s)... done." code)))) + (list code-1 code-2)))) (set-buffer-modified-p nil)) (defun url-filter (proc string) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-annotat.el --- a/lisp/w3/w3-annotat.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-annotat.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,281 +0,0 @@ -;;; w3-annotat.el --- Annotation functions for Emacs-W3 -;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.6 -;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu) -;;; Copyright (c) 1996, 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Private annotation support -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun w3-parse-personal-annotations () - ;; Read in personal annotation file - (if (and - (file-exists-p (format "%s/LOG" w3-personal-annotation-directory)) - (file-readable-p (format "%s/LOG" w3-personal-annotation-directory))) - (save-excursion - (setq w3-personal-annotations nil);; nuke the old list - (let ((start nil) - (end nil) - (txt nil) - (url nil) - (num nil)) - (set-buffer (get-buffer-create " *panno*")) - (erase-buffer) - (insert-file-contents-literally - (format "%s/LOG" w3-personal-annotation-directory)) - (goto-char (point-min)) - (w3-replace-regexp "\n+" "\n") - (goto-char (point-min)) - ;; nuke the header lines - (delete-region (point-min) (progn (forward-line 2) (point))) - (cond - ((eobp) nil) ; Empty LOG file - (t - (if (/= (char-after (1- (point-max))) ?\n) - (save-excursion - (goto-char (point-max)) - (insert "\n"))) - (while (not (eobp)) - (setq start (point) - end (prog2 (end-of-line) (point) (forward-char 1)) - txt (buffer-substring start end) - url (substring txt 0 (string-match " " txt)) - num (url-split - (substring txt (1+ (string-match " " txt)) nil) - "[ \t]")) - (while num - (setq w3-personal-annotations - (cons - (list url - (list (car (car num)) - (w3-grok-annotation-format - (car (car num))))) - w3-personal-annotations) - num (cdr num)))))) - (kill-buffer " *panno*"))))) - -(defun w3-grok-annotation-format (anno) - ;; Grab the title from an annotation - (let ((fname (format "%s/PAN-%s.html" - w3-personal-annotation-directory anno))) - (save-excursion - (set-buffer (get-buffer-create " *annotmp*")) - (erase-buffer) - (if (file-exists-p fname) - (insert-file-contents-literally fname)) - (goto-char (point-min)) - (prog1 - (if (re-search-forward "\\(.*\\)" nil t) - (buffer-substring (match-beginning 1) (match-end 1)) - (concat "Annotation on " - (current-time-string (nth 5 (file-attributes fname))))) - (kill-buffer " *annotmp*"))))) - -(defun w3-is-personal-annotation (url) - ;; Is URL a personal annotation? - (string-match "file:/.*/PAN-.*\\.html" url)) - -(defun w3-delete-personal-annotation-internal (url num) - (save-excursion - (set-buffer (get-buffer-create " *annotmp*")) - (erase-buffer) - (insert-file-contents-literally (format "%s/LOG" - w3-personal-annotation-directory)) - (replace-regexp (format "[ \t]+\\b%s\\b[ \t]*" num) " ") - (goto-char (point-min)) - (delete-matching-lines (format "^%s +$" url)) - (let ((make-backup-files nil) - (version-control nil) - (require-final-newline t)) - (write-region (point-min) (point-max) - (format "%s/LOG" - w3-personal-annotation-directory))) - (kill-buffer " *annotmp*") - (let ((anno w3-personal-annotations)) - (setq w3-personal-annotations nil) - (while anno - (if (not (string= num (car (car (cdr (car anno)))))) - (setq w3-personal-annotations - (cons (car anno) w3-personal-annotations))) - (setq anno (cdr anno))) - (delete-file (format "%s/PAN-%s.html" - w3-personal-annotation-directory num))))) - -(defun w3-delete-personal-annotation () - "Delete a personal annotation." - (interactive) - (let ((url (url-view-url t))) - (cond - ((w3-is-personal-annotation (url-view-url t)) - (let ((num nil) - (annotated-url nil) - (anno w3-personal-annotations)) - (string-match "file:/.*/PAN-\\(.*\\)\\.html" url) - (setq num (match-string 1 url)) - (while anno - (if (equal num (car (car (cdr (car anno))))) - (setq annotated-url (car (car anno)))) - (setq anno (cdr anno))) - (if (not annotated-url) - (message "Couldn't find url that this is annotating!") - (w3-delete-personal-annotation-internal annotated-url num) - (w3-quit)))) - (t - (let* ((tmp w3-personal-annotations) - (thelist nil) - (node nil) - (todel nil)) - (if (not (assoc url tmp)) - (message "No personal annotations.") - (while tmp - (setq node (car tmp)) - (if (string= (car node) url) - (setq thelist (cons (cons (nth 1 (nth 1 node)) "") thelist))) - (setq tmp (cdr tmp))) - (setq todel (completing-read "Delete annotation: " thelist nil t)) - ;; WORK ;; - (message "I should delete %s, but can't." todel))))))) - -(defun w3-personal-annotation-add () - "Add an annotation to this document." - (interactive) - (let ((url (url-view-url t)) - (buf (get-buffer-create "*Personal Annotation*")) - (title (read-string "Title: " - (format "Annotation by %s on %s" - (user-real-login-name) - (current-time-string))))) - (set-buffer buf) - (switch-to-buffer buf) - (erase-buffer) - (if (and w3-annotation-mode (fboundp w3-annotation-mode)) - (funcall w3-annotation-mode) - (message "%S is undefined, using %s" w3-annotation-mode - default-major-mode) - (funcall default-major-mode)) - (w3-annotation-minor-mode 1) - (setq w3-current-annotation (cons url title)) - (insert "\n" - " \n" - " " (url-insert-entities-in-string title) "" - " \n" - "

    " (url-insert-entities-in-string title) "

    \n" - "

    \n" - "

    " (url-insert-entities-in-string (user-full-name)) - (if (stringp url-personal-mail-address) - (concat " <" (url-insert-entities-in-string - url-personal-mail-address) ">") - "") - "
    \n" - "
    " (current-time-string) "
    \n" - "

    \n" - " 
    \n")
-    (save-excursion
-      (insert "\n\n\n
    \n" - "")) - (message "Hit C-cC-c to send this annotation."))) - -(defun w3-annotation-minor-mode (&optional arg) - "Minimal minor mode for entering annotations. Just rebinds C-cC-c to -finish the annotation." - (interactive "P") - (cond - ((null arg) (setq w3-annotation-minor-mode (not w3-annotation-minor-mode))) - ((= 0 arg) (setq w3-annotation-minor-mode nil)) - (t (setq w3-annotation-minor-mode t))) - (cond - ((or w3-running-FSF19 w3-running-xemacs)) - (t (local-set-key "\C-c\C-c" 'w3-personal-annotation-finish))) - ) - -(defun w3-annotation-find-highest-number () - ;; Find the highest annotation number in this buffer - (let (x) - (goto-char (point-min)) - (while (re-search-forward "[^ \t\n]*[ \t]\\(.*\\)" nil t) - (setq x (nconc (mapcar (function (lambda (x) (string-to-int (car x)))) - (url-split (buffer-substring (match-beginning 1) - (match-end 1)) - "[ \t]")) x))) - (if (not x) (setq x '(0))) - (1+ (car (sort x '>))))) - -(defun w3-personal-annotation-finish () - "Finish doing a personal annotation." - (interactive) - (cond - ((or w3-running-FSF19 w3-running-xemacs)) - (t (local-set-key "\C-c\C-c" 'undefined))) - (if (or (not w3-personal-annotation-directory) - (not (file-exists-p w3-personal-annotation-directory)) - (not (file-directory-p w3-personal-annotation-directory))) - (error "No personal annotation directory!") - (let ((url (car w3-current-annotation)) - (txt (buffer-string)) - (title (cdr w3-current-annotation)) - (fname nil) - (num nil)) - (save-excursion - (not-modified) - (kill-buffer (current-buffer)) - (set-buffer (get-buffer-create " *annotmp*")) - (erase-buffer) - (if (file-exists-p ; Insert current LOG file if - ; it exists. - (format "%s/LOG" w3-personal-annotation-directory)) - (insert-file-contents-literally - (format "%s/LOG" w3-personal-annotation-directory)) - (progn ; Otherwise, create a file - (goto-char (point-min)) ; that conforms to first - ; annotation format from NCSA - (insert "ncsa-mosaic-personal-annotation-log-format-1\n") - (insert "Personal\n"))) - (goto-char (point-min)) - (setq num (int-to-string (w3-annotation-find-highest-number)) - fname (format "%s/PAN-%s.html" - w3-personal-annotation-directory num)) - (goto-char (point-min)) - (if (re-search-forward (regexp-quote url) nil t) - (progn - (end-of-line) - (insert " ")) - (goto-char (point-max)) - (insert "\n" url " ")) - (insert num) - (let ((make-backup-files nil) - (version-control nil) - (require-final-newline t)) - (write-region (point-min) (point-max) - (format "%s/LOG" w3-personal-annotation-directory)) - (erase-buffer) - (insert w3-annotation-marker txt) - (write-region (point-min) (point-max) fname)) - (setq w3-personal-annotations - (cons (list url (list num title)) w3-personal-annotations)))))) - -(defun w3-annotation-add () - "Add an annotation to the current document." - (interactive) - (w3-personal-annotation-add)) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-auto.el --- a/lisp/w3/w3-auto.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-auto.el Mon Aug 13 09:13:56 2007 +0200 @@ -3,14 +3,6 @@ ;; About pages (autoload 'w3-about "w3-about") -;; Annotation handling -(autoload 'w3-parse-personal-annotations "w3-annotat") -(autoload 'w3-is-personal-annotation "w3-annotat") -(autoload 'w3-delete-personal-annotation "w3-annotat") -(autoload 'w3-personal-annotation-add "w3-annotat") -(autoload 'w3-annotation-minor-mode "w3-annotat") -(autoload 'w3-annotation-add "w3-annotat") - ;; Hotlist handling (autoload 'w3-read-html-bookmarks "w3-hot") (autoload 'w3-hotlist-apropos "w3-hot") @@ -24,7 +16,6 @@ (autoload 'w3-hotlist-add-document "w3-hot") ;; Printing -(autoload 'w3-print-with-ps-print "w3-print") (autoload 'w3-print-this-url "w3-print") (autoload 'w3-print-url-under-point "w3-print") (autoload 'w3-parse-tree-to-latex "w3-latex") diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-display.el --- a/lisp/w3/w3-display.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-display.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-display.el --- display engine v99999 ;; Author: wmperry -;; Created: 1997/01/31 04:26:17 -;; Version: 1.115 +;; Created: 1997/02/14 17:51:17 +;; Version: 1.127 ;; Keywords: faces, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -32,6 +32,7 @@ (require 'w3-widget) (require 'w3-imap) +(define-widget-keywords :emacspeak-help) (autoload 'sentence-ify "flame") (autoload 'string-ify "flame") (autoload '*flame "flame") @@ -365,7 +366,11 @@ (point))))) (goto-char (point-max)) (add-text-properties w3-scratch-start-point - (point) (list 'face w3-active-faces 'duplicable t)) + (point) (list 'face w3-active-faces + 'start-open t + 'end-open t + 'rear-nonsticky t + 'duplicable t)) (if (car w3-active-voices) (add-text-properties w3-scratch-start-point (point) (list 'personality (car w3-active-voices)))) @@ -618,43 +623,47 @@ (defun w3-maybe-start-image-download (widget) (let* ((src (widget-get widget 'src)) (cached-glyph (w3-image-cached-p src))) - (if (and cached-glyph (widget-glyphp cached-glyph)) - (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)) - (cond - ((or w3-delay-image-loads ; Delaying images - (not (fboundp 'valid-specifier-domain-p)) ; Can't do images - (eq (device-type) 'tty)) ; Why bother? - (w3-add-delayed-graphic widget)) - ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! - (w3-warn 'images (format "Skipping image %s" (url-basepath src t))) - (w3-add-delayed-graphic widget)) - (t ; Grab the images - (let ( - (url-request-method "GET") - (old-asynch url-be-asynchronous) - (url-request-data nil) - (url-request-extra-headers nil) - (url-source t) - (url-mime-accept-string (substring - (mapconcat - (function - (lambda (x) - (if x - (concat (car x) ",") - ""))) - w3-allowed-image-types "") - 0 -1)) - (url-working-buffer (generate-new-buffer-name " *W3GRAPH*"))) - (setq-default url-be-asynchronous t) - (setq w3-graphics-list (cons (cons src (make-glyph)) - w3-graphics-list)) - (save-excursion - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-callback-data (list widget) - url-be-asynchronous t - url-current-callback-func 'w3-finalize-image-download) - (url-retrieve src)) - (setq-default url-be-asynchronous old-asynch))))))) + (cond + ((and cached-glyph + (widget-glyphp cached-glyph) + (not (eq 'nothing + (image-instance-type + (glyph-image-instance cached-glyph))))) + (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting))) + ((or w3-delay-image-loads ; Delaying images + (not (fboundp 'valid-specifier-domain-p)) ; Can't do images + (eq (device-type) 'tty)) ; Why bother? + (w3-add-delayed-graphic widget)) + ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! + (message "Skipping image %s" (url-basepath src t)) + (w3-add-delayed-graphic widget)) + (t ; Grab the images + (let ( + (url-request-method "GET") + (old-asynch url-be-asynchronous) + (url-request-data nil) + (url-request-extra-headers nil) + (url-source t) + (url-mime-accept-string (substring + (mapconcat + (function + (lambda (x) + (if x + (concat (car x) ",") + ""))) + w3-allowed-image-types "") + 0 -1)) + (url-working-buffer (generate-new-buffer-name " *W3GRAPH*"))) + (setq-default url-be-asynchronous t) + (setq w3-graphics-list (cons (cons src (make-glyph)) + w3-graphics-list)) + (save-excursion + (set-buffer (get-buffer-create url-working-buffer)) + (setq url-current-callback-data (list widget) + url-be-asynchronous t + url-current-callback-func 'w3-finalize-image-download) + (url-retrieve src)) + (setq-default url-be-asynchronous old-asynch)))))) (defun w3-finalize-image-download (widget) (let ((glyph nil) @@ -670,7 +679,7 @@ (cond ((w3-image-invalid-glyph-p glyph) (setq glyph nil) - (w3-warn 'image (format "Reading of %s failed." url))) + (message "Reading of %s failed." url)) ((eq (aref glyph 0) 'xbm) (let ((temp-fname (url-generate-unique-filename "%s.xbm"))) (save-excursion @@ -794,6 +803,7 @@ (setq st (min (point-max) (1+ nd)))))))) (defun w3-size-of-tree (tree minmax) + (declare (special args)) (save-excursion (save-restriction (narrow-to-region (point) (point)) @@ -839,6 +849,7 @@ (defun w3-display-table-dimensions (node) ;; fill-column sets maximum width + (declare (special args)) (let (min-vector max-vector rows cols @@ -1205,7 +1216,7 @@ (save-restriction (narrow-to-region (point) (point)) (setq fill-column avgwidth - inhibit-read-only t + ;; inhibit-read-only t w3-last-fill-pos (point-min) i 0) ;; skip over columns that have leftover content @@ -1299,7 +1310,7 @@ (setq this-rectangle (aref formatted-cols i)) (if (> height (length this-rectangle)) (let ((colspan-fill-line - (make-string (aref table-colwidth i) ? ))) + (make-string (abs (aref table-colwidth i)) ? ))) (case valign ((center middle) (aset formatted-cols i @@ -1481,6 +1492,7 @@ (content-stack (list (list node))) (right-margin-stack (list fill-column)) (left-margin-stack (list 0)) + ;; (inhibit-read-only t) node insert-before insert-after @@ -1600,9 +1612,9 @@ (list 'link :args nil :value "" :tag "" :action 'w3-follow-hyperlink - :from - (set-marker (make-marker) st) + :from (set-marker (make-marker) st) :help-echo 'w3-widget-echo + :emacspeak-help 'w3-widget-echo ) (alist-to-plist args)))) (w3-handle-content node) @@ -1751,7 +1763,8 @@ (or w3-maximum-line-length (window-width))) fill-prefix "") - (set (make-local-variable 'inhibit-read-only) t)) + ;; (set (make-local-variable 'inhibit-read-only) t) + ) (w3-handle-content node) ) (*invisible @@ -1808,25 +1821,25 @@ w3-current-form-number) args)) (w3-handle-content node))) - (keygen - (w3-form-add-element 'keygen - (or (w3-get-attribute 'name) - (w3-get-attribute 'id) - "keygen") - nil ; value - nil ; size - nil ; maxlength - nil ; default - w3-display-form-id ; action - nil ; options - w3-current-form-number - (w3-get-attribute 'id) ; id - nil ; checked - (car w3-active-faces))) +; (keygen +; (w3-form-add-element 'keygen +; (or (w3-get-attribute 'name) +; (w3-get-attribute 'id) +; "keygen") +; nil ; value +; nil ; size +; nil ; maxlength +; nil ; default +; w3-display-form-id ; action +; nil ; options +; w3-current-form-number +; (w3-get-attribute 'id) ; id +; nil ; checked +; (car w3-active-faces))) (input (w3-form-add-element (w3-display-normalize-form-info args) - (car w3-active-faces)) + w3-active-faces) (w3-handle-empty-tag) ) (select @@ -1870,7 +1883,7 @@ (w3-handle-content node)) (setq plist (plist-put plist 'type 'option) plist (plist-put plist 'options options)) - (w3-form-add-element plist (car w3-active-faces)) + (w3-form-add-element plist w3-active-faces) ;; This should really not be necessary, but some versions ;; of the widget library leave point _BEFORE_ the menu ;; widget instead of after. @@ -1882,7 +1895,7 @@ (apply 'concat (nth 2 node))))) (setq plist (plist-put plist 'type 'multiline) plist (plist-put plist 'value value)) - (w3-form-add-element plist (car w3-active-faces))) + (w3-form-add-element plist w3-active-faces)) (w3-handle-empty-tag) ) (style @@ -1954,34 +1967,46 @@ (- nd st))) +(defun w3-fixup-eol-faces () + ;; Remove 'face property at end of lines - underlining screws up stuff + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (put-text-property (match-beginning 0) (match-end 0) 'face nil))))) + (defsubst w3-finish-drawing () - (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting) - (let (url glyph widget) - (while w3-image-widgets-waiting - (setq widget (car w3-image-widgets-waiting) - w3-image-widgets-waiting (cdr w3-image-widgets-waiting) - url (widget-get widget 'src) - glyph (cdr-safe (assoc url w3-graphics-list))) - (widget-value-set widget glyph))) - ;;(w3-handle-annotations) - ;;(w3-handle-headers) - ) + (let (url glyph widget) + (while w3-image-widgets-waiting + (setq widget (car w3-image-widgets-waiting) + w3-image-widgets-waiting (cdr w3-image-widgets-waiting) + url (widget-get widget 'src) + glyph (cdr-safe (assoc url w3-graphics-list))) + (condition-case nil + (widget-value-set widget glyph) + (error nil)))) + (and (not w3-running-xemacs) + (not (eq (device-type) 'tty)) + (w3-fixup-eol-faces)) + ;;(w3-handle-headers) ) (defun w3-region (st nd) (if (not w3-setup-done) (w3-do-setup)) (let* ((source (buffer-substring st nd)) - (w3-display-same-buffer t) + (w3-dislplay-same-buffer t) (parse nil)) - (save-excursion - (set-buffer (get-buffer-create " *w3-region*")) - (erase-buffer) - (insert source) - (setq parse (w3-parse-buffer (current-buffer)))) - (narrow-to-region st nd) - (delete-region (point-min) (point-max)) - (w3-draw-tree parse) - (w3-finish-drawing))) + (save-window-excursion + (save-excursion + (set-buffer (get-buffer-create " *w3-region*")) + (erase-buffer) + (insert source) + (setq parse (w3-parse-buffer (current-buffer)))) + (narrow-to-region st nd) + (delete-region (point-min) (point-max)) + (w3-draw-tree parse) + (w3-finish-drawing) + (widen)))) (defun w3-refresh-buffer () (interactive) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-emulate.el --- a/lisp/w3/w3-emulate.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-emulate.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-emulate.el --- All variable definitions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/22 16:28:30 -;; Version: 1.6 +;; Created: 1997/02/04 19:21:18 +;; Version: 1.11 ;; Keywords: comm, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -80,9 +80,9 @@ (define-key w3-netscape-emulation-minor-mode-map [right] 'scroll-left) (define-key w3-netscape-emulation-minor-mode-map [left] 'scroll-right) (define-key w3-netscape-emulation-minor-mode-map [(meta left)] - 'w3-backward-in-history) + 'w3-history-backward) (define-key w3-netscape-emulation-minor-mode-map [(meta right)] - 'w3-forward-in-history) + 'w3-history-forward) (defun turn-on-netscape-emulation () (interactive) @@ -186,31 +186,72 @@ (setq w3-lynx-emulation-minor-mode t w3-netscape-emulation-minor-mode nil)))) +;; The list of keybindings for lynx minor mode was compiled from: +;; http://www.crl.com/~subir/lynx/lynx_help/keystroke_commands/keystroke_help.htm + +;; Movement +(define-key w3-lynx-emulation-minor-mode-map [up] 'w3-widget-backward) +(define-key w3-lynx-emulation-minor-mode-map [down] 'w3-widget-forward) +(define-key w3-lynx-emulation-minor-mode-map [right] 'w3-follow-link) +(define-key w3-lynx-emulation-minor-mode-map [left] 'w3-history-backward) + +;; Scrolling (define-key w3-lynx-emulation-minor-mode-map "+" 'w3-scroll-up) (define-key w3-lynx-emulation-minor-mode-map "-" 'scroll-down) (define-key w3-lynx-emulation-minor-mode-map "b" 'scroll-down) -(define-key w3-lynx-emulation-minor-mode-map "a" 'w3-hotlist-add-document) -(define-key w3-lynx-emulation-minor-mode-map "c" 'w3-mail-document-author) -(define-key w3-lynx-emulation-minor-mode-map "e" 'w3-edit-source) -(define-key w3-lynx-emulation-minor-mode-map "g" 'w3-fetch) -(define-key w3-lynx-emulation-minor-mode-map "i" 'ignore) -(define-key w3-lynx-emulation-minor-mode-map "m" 'w3) -(define-key w3-lynx-emulation-minor-mode-map "o" 'ignore) -(define-key w3-lynx-emulation-minor-mode-map "p" 'w3-print-this-url) -(define-key w3-lynx-emulation-minor-mode-map "q" 'w3-quit) -(define-key w3-lynx-emulation-minor-mode-map "/" 'w3-search-forward) -(define-key w3-lynx-emulation-minor-mode-map "s" 'w3-search-forward) -(define-key w3-lynx-emulation-minor-mode-map "n" 'w3-search-again) -(define-key w3-lynx-emulation-minor-mode-map "v" 'w3-show-hotlist) -(define-key w3-lynx-emulation-minor-mode-map "=" 'w3-document-information) +(define-key w3-lynx-emulation-minor-mode-map "\C-a" 'w3-start-of-document) +(define-key w3-lynx-emulation-minor-mode-map "\C-e" 'w3-end-of-document) +(define-key w3-lynx-emulation-minor-mode-map "\C-f" 'scroll-down) +(define-key w3-lynx-emulation-minor-mode-map "\C-n" 'ignore) ; down 2 +(define-key w3-lynx-emulation-minor-mode-map "\C-p" 'ignore) ; up 2 +(define-key w3-lynx-emulation-minor-mode-map ")" 'ignore) ; forward half +(define-key w3-lynx-emulation-minor-mode-map "(" 'ignore) ; back half +(define-key w3-lynx-emulation-minor-mode-map "#" 'w3-toggle-toolbar) + +;; Dired bindings don't have any meaning for us + +;; Other +(define-key w3-lynx-emulation-minor-mode-map "?" 'w3-help) +(define-key w3-lynx-emulation-minor-mode-map "a" 'w3-hotlist-add-document) +(define-key w3-lynx-emulation-minor-mode-map "c" 'w3-mail-document-author) +(define-key w3-lynx-emulation-minor-mode-map "d" 'w3-download-url) +(define-key w3-lynx-emulation-minor-mode-map "e" 'ignore) ; edit current +(define-key w3-lynx-emulation-minor-mode-map "f" 'dired) +(define-key w3-lynx-emulation-minor-mode-map "g" 'w3-fetch) +(define-key w3-lynx-emulation-minor-mode-map "h" 'w3-help) +(define-key w3-lynx-emulation-minor-mode-map "i" 'ignore) +(define-key w3-lynx-emulation-minor-mode-map "j" 'w3-use-hotlist) +(define-key w3-lynx-emulation-minor-mode-map "k" 'describe-mode) +(define-key w3-lynx-emulation-minor-mode-map "l" 'w3-complete-link) +(define-key w3-lynx-emulation-minor-mode-map "m" 'w3) +(define-key w3-lynx-emulation-minor-mode-map "n" 'w3-search-again) +(define-key w3-lynx-emulation-minor-mode-map "o" 'w3-preferences-edit) +(define-key w3-lynx-emulation-minor-mode-map "p" 'w3-print-this-url) +(define-key w3-lynx-emulation-minor-mode-map "q" 'w3-quit) +(define-key w3-lynx-emulation-minor-mode-map "r" 'w3-hotlist-delete) +(define-key w3-lynx-emulation-minor-mode-map "t" 'ignore) ; tag +(define-key w3-lynx-emulation-minor-mode-map "u" 'w3-history-backward) +(define-key w3-lynx-emulation-minor-mode-map "/" 'w3-search-forward) +(define-key w3-lynx-emulation-minor-mode-map "v" 'w3-show-hotlist) +(define-key w3-lynx-emulation-minor-mode-map "V" 'w3-show-hotlist) +(define-key w3-lynx-emulation-minor-mode-map "x" 'w3-follow-link) +(define-key w3-lynx-emulation-minor-mode-map "z" 'keyboard-quit) +(define-key w3-lynx-emulation-minor-mode-map "=" 'w3-document-information) +(define-key w3-lynx-emulation-minor-mode-map "\\" 'w3-source-document) +(define-key w3-lynx-emulation-minor-mode-map "!" 'shell) +(define-key w3-lynx-emulation-minor-mode-map "'" 'ignore) ; toggle comment +(define-key w3-lynx-emulation-minor-mode-map "`" 'ignore) ; toggle comment +(define-key w3-lynx-emulation-minor-mode-map "*" 'ignore) ; toggle image_links +(define-key w3-lynx-emulation-minor-mode-map "@" 'ignore) ; toggle raw 8-bit +(define-key w3-lynx-emulation-minor-mode-map "[" 'ignore) ; pseudo-inlines +(define-key w3-lynx-emulation-minor-mode-map "]" 'ignore) ; send head +(define-key w3-lynx-emulation-minor-mode-map "\"" 'ignore) ; toggle quoting (define-key w3-lynx-emulation-minor-mode-map "\C-r" 'w3-reload-document) (define-key w3-lynx-emulation-minor-mode-map "\C-w" 'w3-refresh-buffer) -(define-key w3-lynx-emulation-minor-mode-map "\\" 'w3-source-document) -(define-key w3-lynx-emulation-minor-mode-map "!" 'shell) -(define-key w3-lynx-emulation-minor-mode-map [up] 'w3-widget-backward) -(define-key w3-lynx-emulation-minor-mode-map [down] 'w3-widget-forward) -(define-key w3-lynx-emulation-minor-mode-map [right] 'w3-follow-link) -(define-key w3-lynx-emulation-minor-mode-map [left] 'w3-backward-in-history) +(define-key w3-lynx-emulation-minor-mode-map "\C-u" 'ignore) ; erase input +(define-key w3-lynx-emulation-minor-mode-map "\C-g" 'keyboard-quit) +(define-key w3-lynx-emulation-minor-mode-map "\C-t" 'ignore) ; toggle trace +(define-key w3-lynx-emulation-minor-mode-map "\C-k" 'ignore) ; cookie jar (provide 'w3-emulate) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-forms.el --- a/lisp/w3/w3-forms.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-forms.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-forms.el --- Emacs-w3 forms parsing code for new display engine ;; Author: wmperry -;; Created: 1997/01/28 14:21:54 -;; Version: 1.55 +;; Created: 1997/02/13 23:10:23 +;; Version: 1.70 ;; Keywords: faces, help, comm, data, languages ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -29,20 +29,44 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FORMS processing for html 2.0/3.0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(eval-when-compile + (require 'cl)) + (eval-and-compile (require 'w3-display) - (require 'widget)) + (require 'widget) + (require 'widget-edit)) (require 'w3-vars) (require 'mule-sysdp) +(defvar w3-form-use-old-style nil + "*Non-nil means use the old way of interacting for form fields.") + (define-widget-keywords :emacspeak-help :w3-form-data) -(defvar w3-form-keymap (copy-keymap global-map)) -(define-key w3-form-keymap "\r" 'w3-form-maybe-submit-by-keypress) -(define-key w3-form-keymap "\n" 'w3-form-maybe-submit-by-keypress) -(define-key w3-form-keymap "\t" 'w3-widget-forward) -(define-key w3-form-keymap [(shift tab)] 'w3-widget-backward) +(defvar w3-form-keymap + (let ((map (copy-keymap global-map)) + (eol-loc (where-is-internal 'end-of-line nil t))) + (if widget-keymap + (cl-map-keymap (function + (lambda (key binding) + (define-key map + (if (vectorp key) key (vector key)) + (case binding + (widget-backward 'w3-widget-backward) + (widget-forward 'w3-widget-forward) + (otherwise binding))))) + widget-keymap)) + (define-key map [return] 'w3-form-maybe-submit-by-keypress) + (define-key map "\r" 'w3-form-maybe-submit-by-keypress) + (define-key map "\n" 'w3-form-maybe-submit-by-keypress) + (define-key map "\t" 'w3-widget-forward) + (define-key map "\C-k" 'widget-kill-line) + (define-key map "\C-a" 'widget-beginning-of-line) + (if eol-loc + (define-key map eol-loc 'widget-end-of-line)) + map)) ;; A form entry area is a vector ;; [ type name default-value value maxlength options widget plist] @@ -84,16 +108,21 @@ (multiline 21) (hidden nil) (file (or size 26)) - ((float password text int) (or size 20)) + ((float password text int) + (if w3-form-use-old-style + (or size 22) + (or size 20))) (image (+ 2 (length (or (plist-get (w3-form-element-plist el) 'alt) "Form-Image")))) (option - (or size - (length (caar (sort (w3-form-element-options el) - (function - (lambda (x y) - (>= (length (car x)) (length (car y)))))))))) + (let ((options (copy-sequence (w3-form-element-options el)))) + (or size + (length (caar (sort options + (function + (lambda (x y) + (>= (length (car x)) + (length (car y))))))))))) (otherwise (or size 22)))) ;;###autoload @@ -120,19 +149,23 @@ (if size (set-text-properties (point) (progn (insert-char ?T size) (point)) - (list 'w3-form-info el + (list 'w3-form-info (cons el face) 'start-open t 'end-open t 'rear-nonsticky t))))) (defun w3-form-resurrect-widgets () (let ((st (point-min)) - info nd node action) + ;; FIXME! For some reason this loses on long lines right now. + (widget-push-button-gui nil) + info nd node action face) (while st (if (setq info (get-text-property st 'w3-form-info)) (progn (setq nd (or (next-single-property-change st 'w3-form-info) (point-max)) + face (cdr info) + info (car info) action (w3-form-element-action info) node (assoc action w3-form-elements)) (goto-char st) @@ -143,7 +176,7 @@ (setcdr node (cons info (cdr node))) (setq w3-form-elements (cons (cons action (list info)) w3-form-elements))) - (w3-form-add-element-internal info) + (w3-form-add-element-internal info face) (setq st (next-single-property-change st 'w3-form-info))) (setq st (next-single-property-change st 'w3-form-info)))))) @@ -173,9 +206,10 @@ (while widgets (setq widget (pop widgets)) (widget-put widget :emacspeak-help 'w3-form-summarize-field) + (widget-put widget :help-echo 'w3-form-summarize-field) (widget-put widget :w3-form-data el)))) -(defun w3-form-add-element-internal (el) +(defun w3-form-add-element-internal (el face) (let* ((widget nil) (buffer-read-only nil) (inhibit-read-only t) @@ -184,7 +218,7 @@ 'w3-widget-creation-function) 'w3-form-default-widget-creator) widget (and (fboundp widget-creation-function) - (funcall widget-creation-function el nil))) + (funcall widget-creation-function el face))) (if (not widget) nil (w3-form-mark-widget widget el)))) @@ -230,7 +264,7 @@ (defun w3-form-create-checkbox (el face) (widget-create 'checkbox - :value-face face + :button-face face (and (w3-form-element-default-value el) t))) (defun w3-form-radio-button-update (widget child event) @@ -281,6 +315,7 @@ (widget-create 'push-button :notify 'ignore :button-face face + :value-face face val))) (defun w3-form-create-image (el face) @@ -302,6 +337,7 @@ (defun w3-form-create-file-browser (el face) (widget-create 'file + :button-face face :value-face face :size (w3-form-element-size el) :must-match t @@ -333,6 +369,7 @@ :ignore-case t :tag "Key Length" :size (1+ longest) + :button-face face :value-face face options))) @@ -345,12 +382,16 @@ :format "%v" :size size :value-face face + :button-face face (mapcar (function (lambda (x) (list 'choice-item :format "%[%t%]" :emacspeak-help 'w3-form-summarize-field + :menu-tag-get (` (lambda (zed) (, (car x)))) :tag (mule-truncate-string (car x) size ? ) + :button-face face + :value-face face :value (car x)))) (w3-form-element-options el))))) (widget-value-set widget (w3-form-element-value el)) @@ -365,45 +406,52 @@ "Multiline text area")) (defun w3-form-create-integer (el face) - (widget-create 'integer - :size (w3-form-element-size el) - :value-face face - :tag "" - :format "%v" - :keymap w3-form-keymap - :w3-form-data el - (w3-form-element-value el))) + (if w3-form-use-old-style + (w3-form-default-widget-creator el face) + (widget-create 'integer + :size (w3-form-element-size el) + :value-face face + :tag "" + :format "%v" + :keymap w3-form-keymap + :w3-form-data el + (w3-form-element-value el)))) (defun w3-form-create-float (el face) - (widget-create 'number - :size (w3-form-element-size el) - :value-face face - :format "%v" - :tag "" - :keymap w3-form-keymap - :w3-form-data el - (w3-form-element-value el))) + (if w3-form-use-old-style + (w3-form-default-widget-creator el face) + (widget-create 'number + :size (w3-form-element-size el) + :value-face face + :format "%v" + :tag "" + :keymap w3-form-keymap + :w3-form-data el + (w3-form-element-value el)))) (defun w3-form-create-text (el face) - (widget-create 'editable-field - :keymap w3-form-keymap - :size (w3-form-element-size el) - :value-face face - :w3-form-data el - (w3-form-element-value el))) + (if w3-form-use-old-style + (w3-form-default-widget-creator el face) + (widget-create 'editable-field + :keymap w3-form-keymap + :size (w3-form-element-size el) + :value-face face + :w3-form-data el + (w3-form-element-value el)))) (defun w3-form-create-password (el face) ;; *sigh* This will fail under XEmacs, but I can yell at them about ;; upgrading separately for the release of 19.15 and 20.0 - (if (boundp :secret) - (widget-create 'editable-field - :secret ?* - :keymap w3-form-keymap - :size (w3-form-element-size el) - :value-face face - :w3-form-data el - (w3-form-element-value el)) - (w3-form-default-widget-creator el face))) + (if w3-form-use-old-style + (w3-form-default-widget-creator el face) + (widget-create 'editable-field + :secret ?* + :keymap w3-form-keymap + :size (w3-form-element-size el) + :value-face face + :button-face face + :w3-form-data el + (w3-form-element-value el)))) (defun w3-form-default-widget-creator (el face) (widget-create 'link @@ -411,6 +459,7 @@ :value-to-internal 'w3-form-default-button-update :size (w3-form-element-size el) :value-face face + :button-face face :w3-form-data el (w3-form-element-value el))) @@ -422,7 +471,7 @@ (if (eq 'password (w3-form-element-type info)) (make-string (length v) ?*) v) - (w3-form-element-size info) ?_))) + (w3-form-element-size info) ? ))) v)) (defun w3-form-default-button-callback (widget &rest ignore) @@ -452,7 +501,7 @@ (put 'option 'w3-summarize-function 'w3-form-summarize-option-list) (put 'keygen 'w3-summarize-function 'w3-form-summarize-keygen-list) (put 'image 'w3-summarize-function 'w3-form-summarize-image) -(put 'hidden 'w3-summariez-function 'ignore) +(put 'hidden 'w3-summarize-function 'ignore) (defun w3-form-summarize-field (widget &rest ignore) "Sumarize a widget that should be a W3 form entry area. @@ -530,7 +579,7 @@ (let ((name (w3-form-element-name data)) (label (w3-form-field-label data)) (cur-value (widget-value (w3-form-element-widget data))) - (this-value (widget-value widget))) + (this-value (widget-value (widget-get-sibling widget)))) (format "Radio button %s is %s, could be %s" (or label name) cur-value this-value))) @@ -639,7 +688,7 @@ deft (w3-form-element-default-value formobj) type (w3-form-element-type formobj)) (case type - ((submit reset image) nil) + ((submit reset image hidden) nil) (radio (setq deft (widget-get widget 'w3-form-default-value)) (if (and widget deft) @@ -823,6 +872,7 @@ (lambda (char) (cond ((= char ? ) "+") + ((memq char '(?: ?/)) (char-to-string char)) ((memq char url-unreserved-chars) (char-to-string char)) (t (upcase (format "%%%02x" char)))))) (mule-encode-string chunk) "")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-menu.el --- a/lisp/w3/w3-menu.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-menu.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-menu.el --- Menu functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/21 20:54:49 -;; Version: 1.25 +;; Created: 1997/02/13 23:04:55 +;; Version: 1.29 ;; Keywords: menu, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -44,8 +44,8 @@ (defvar w3-links-menu nil "Menu for w3-mode in XEmacs.") (make-variable-buffer-local 'w3-links-menu) -(defvar w3-use-menus '(file edit view go bookmark options - buffers style emacs nil help) +(defvar w3-use-menus '(file edit view go bookmark options buffers style + emacs nil help) "*Non-nil value causes W3 to provide a menu interface. A value that is a list causes W3 to install its own menubar. A value of 1 causes W3 to install a \"W3\" item in the Emacs menubar. @@ -70,7 +70,11 @@ If nil appears in the list, it should appear exactly once. All menus after nil in the list will be displayed flushright in the -menubar.") +menubar. + +NOTE! The current port of Emacs to Windows NT/95 does not support +buttons in the menubar, so the 'emacs' keyword is currently ignored +on that platform.") (defun w3-menu-hotlist-constructor (menu-items) (or (cdr w3-html-bookmarks) @@ -226,7 +230,6 @@ ["PostScript" (w3-mail-current-document nil "PostScript") t] ["LaTeX Source" (w3-mail-current-document nil "LaTeX Source") t] ) - ["Add Annotation" w3-annotation-add w3-personal-annotation-directory] (if w3-running-xemacs "---:shadowDoubleEtchedIn" "---") @@ -277,8 +280,8 @@ (defconst w3-menu-go-menu (list "Go" - ["Forward" w3-forward-in-history t] - ["Backward" w3-backward-in-history t] + ["Forward" w3-history-forward (cdr (w3-history-find-url-internal (url-view-url t)))] + ["Back" w3-history-backward (car (w3-history-find-url-internal (url-view-url t)))] ["Home" w3 w3-default-homepage] ["View History..." w3-show-history-list url-keep-history] "----" @@ -466,7 +469,13 @@ (search (cons "Search" w3-menu-fsfemacs-search-menu)) (emacs - (cons "[Emacs]" 'w3-menu-toggle-menubar)))) + ;; FIXME!!! Currently, win32 doesn't support buttons + ;; in menubars, so we hack around it and ignore the + ;; 'emacs keyword on that platform. REMOVE THIS CODE + ;; as soon as that is fixed. 19.35 timeframe? + (if (eq (device-type) 'win32) + nil + (cons "[Emacs]" 'w3-menu-toggle-menubar))))) cons (vec (vector 'rootmenu 'w3 nil)) ;; menus appear in the opposite order that we @@ -627,10 +636,7 @@ url-privacy-level url-proxy-services url-standalone-mode - url-use-hypertext-dired url-use-hypertext-gopher - w3-color-filter - w3-color-use-reducing w3-default-homepage w3-default-stylesheet w3-delay-image-loads diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-mouse.el --- a/lisp/w3/w3-mouse.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-mouse.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/18 00:42:22 -;; Version: 1.6 +;; Created: 1997/02/13 23:05:39 +;; Version: 1.7 ;; Keywords: mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -81,7 +81,9 @@ (if w3-running-FSF19 (progn - (define-key w3-mode-map [down-mouse-3] 'w3-popup-menu) - (define-key w3-mode-map [mouse-movement] 'w3-mouse-handler))) + (define-key w3-mode-map [mouse-movement] 'w3-mouse-handler) + (if w3-popup-menu-on-mouse-3 + (define-key w3-mode-map [down-mouse-3] 'w3-popup-menu)))) + (provide 'w3-mouse) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-parse.el --- a/lisp/w3/w3-parse.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-parse.el Mon Aug 13 09:13:56 2007 +0200 @@ -2136,7 +2136,7 @@ ;; Read the attributes from a start-tag. (if w3-p-d-end-tag-p - (if (looking-at "[ \t\r\n/]*>") + (if (looking-at "[ \t\r\n/]*[<>]") nil ;; This is in here to deal with those idiots who stick ;; attribute/value pairs on end tags. *sigh* @@ -2330,6 +2330,19 @@ (setq tag-attributes (cons (cons 'class (list w3-p-s-btdt)) tag-attributes)))) ) + (if (not (eq w3-p-d-tag-name 'input)) + nil + (setq w3-p-s-btdt (concat ":" + (downcase + (or (cdr-safe + (assq 'type tag-attributes)) + "text")))) + (if (assq 'class tag-attributes) + (setcdr (assq 'class tag-attributes) + (cons w3-p-s-btdt + (cdr (assq 'class tag-attributes)))) + (setq tag-attributes (cons (cons 'class (list w3-p-s-btdt)) + tag-attributes)))) ) ;; Process the end of the tag. diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-print.el --- a/lisp/w3/w3-print.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-print.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-print.el --- Printing support for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.6 +;; Created: 1997/02/07 01:05:01 +;; Version: 1.7 ;; Keywords: faces, help, printing, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -25,77 +25,12 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307, USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-use-ps-print nil - "*If non-nil, then printing will be done via the ps-print package by -James C. Thompson .") - -(defun w3-face-type (face) - "Return a list specifying what a face looks like. ie: '(bold italic)" - (let ((font (or (face-font face) (face-font 'default))) - (retval nil)) - (if (not (stringp font)) - (setq font - (cond - ((and (fboundp 'fontp) (not (fontp font))) nil) - ((fboundp 'font-truename) (font-truename font)) - ((fboundp 'font-name) (font-name font)) - (t nil)))) - (cond - ((not font) nil) - ((string-match "^-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-" font) - (let ((wght (substring font (match-beginning 3) (match-end 3))) - (slnt (substring font (match-beginning 4) (match-end 4)))) - (if (string-match "bold" wght) - (setq retval (cons 'bold retval))) - (if (or (string-match "i" slnt) (string-match "o" slnt)) - (setq retval (cons 'italic retval))) - (if (and (fboundp 'face-underline-p) - (face-underline-p face)) - (setq retval (cons 'underline retval))))) - ((and (symbolp face) (string-match "bold" (symbol-name face))) - (setq retval '(bold))) - ((and (symbolp face) (string-match "italic" (symbol-name face))) - (setq retval '(italic))) - (t nil)) - retval)) - -(defun w3-print-with-ps-print (&optional buffer function) - "Print a buffer using `ps-print-buffer-with-faces'. -This function wraps `ps-print-buffer-with-faces' so that the w3 faces -will be correctly listed in ps-bold-faces and ps-italic-faces" - (interactive) - (require 'ps-print) - (setq buffer (or buffer (current-buffer)) - function (or function 'ps-print-buffer-with-faces)) - (let ((ps-bold-faces ps-bold-faces) - (ps-italic-faces ps-italic-faces) - (inhibit-read-only t) - (ps-underline-faces (cond - ((boundp 'ps-underline-faces) - (symbol-value 'ps-underline-faces)) - ((boundp 'ps-underlined-faces) - (symbol-value 'ps-underlined-faces)) - (t nil))) - (ps-underlined-faces nil) - (ps-left-header '(ps-get-buffer-name url-view-url)) - (faces (face-list)) - (data nil) - (face nil)) - (if (string< ps-print-version "1.6") - (while faces - (setq face (car faces) - data (w3-face-type face) - faces (cdr faces)) - (if (and (memq 'bold data) (not (memq face ps-bold-faces))) - (setq ps-bold-faces (cons face ps-bold-faces))) - (if (and (memq 'italic data) (not (memq face ps-italic-faces))) - (setq ps-italic-faces (cons face ps-italic-faces))) - (if (and (memq 'underline data) (not (memq face ps-underline-faces))) - (setq ps-underline-faces (cons face ps-underline-faces)))) - (setq ps-underlined-faces ps-underline-faces)) - (save-excursion - (set-buffer buffer) - (funcall function)))) +(defvar w3-postscript-print-function 'ps-print-buffer-with-faces + "*Name of the function to use to print a buffer as PostScript. +This should take no arguments, and act on the current buffer. +Possible values include: +ps-print-buffer-with-faces - print immediately +ps-spool-buffer-with-faces - spool for later") (defun w3-print-this-url (&optional url format) "Print out the current document (in LaTeX format)" @@ -125,7 +60,7 @@ (equal "" format)) (lpr-buffer)) ((equal "PostScript" format) - (w3-print-with-ps-print (current-buffer))) + (funcall w3-postscript-print-function)) ((equal "LaTeX'd" format) (w3-parse-tree-to-latex w3-current-parse url) (save-window-excursion diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-speak.el --- a/lisp/w3/w3-speak.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-speak.el Mon Aug 13 09:13:56 2007 +0200 @@ -168,15 +168,10 @@ delimiters. We then turn on voice-lock-mode. Interactive prefix arg does the opposite. " (interactive "P") - (declare (special w3-delimit-links w3-delimit-emphasis w3-echo-link)) + (declare (special w3-echo-link)) (setq w3-echo-link 'text) (if arg - (progn - (setq w3-delimit-links 'guess - w3-delimit-emphasis 'guess) - (remove-hook 'w3-mode-hook 'w3-speak-mode-hook)) - (setq w3-delimit-links nil - w3-delimit-emphasis nil) + (remove-hook 'w3-mode-hook 'w3-speak-mode-hook) (add-hook 'w3-mode-hook 'w3-speak-mode-hook))) (defun w3-speak-browse-page () diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-toolbar.el --- a/lisp/w3/w3-toolbar.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-toolbar.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-toolbar.el --- Toolbar functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.7 +;; Created: 1997/02/03 15:38:24 +;; Version: 1.8 ;; Keywords: mouse, toolbar ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -79,8 +79,8 @@ not `none'.") (defvar w3-toolbar - '([w3-toolbar-back-icon w3-backward-in-history t "Back in history"] - [w3-toolbar-forw-icon w3-forward-in-history t "Forward in history"] + '([w3-toolbar-back-icon w3-history-backward (car (w3-history-find-url-internal (url-view-url t))) "Back in history"] + [w3-toolbar-forw-icon w3-history-forward (cdr (w3-history-find-url-internal (url-view-url t))) "Forward in history"] [w3-toolbar-home-icon w3 t "Go home"] [:style 2d :size 5] [w3-toolbar-reld-icon w3-reload-document t "Reload document"] diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-vars.el --- a/lisp/w3/w3-vars.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-vars.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-vars.el,v --- All variable definitions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/31 04:28:42 -;; Version: 1.76 +;; Created: 1997/02/14 17:57:21 +;; Version: 1.89 ;; Keywords: comm, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,7 +30,7 @@ ;;; Variable definitions for w3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst w3-version-number - (let ((x "p3.0.52")) + (let ((x "p3.0.59")) (if (string-match "State:[ \t\n]+.\\([^ \t\n]+\\)" x) (setq x (substring x (match-beginning 1) (match-end 1))) (setq x (substring x 1))) @@ -38,7 +38,7 @@ (function (lambda (x) (if (= x ?-) "." (char-to-string x)))) x "")) "Version # of w3-mode.") -(defconst w3-version-date (let ((x "1997/01/31 04:28:42")) +(defconst w3-version-date (let ((x "1997/02/14 17:57:21")) (if (string-match "Date: \\([^ \t\n]+\\)" x) (substring x (match-beginning 1) (match-end 1)) x)) @@ -51,15 +51,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; General configuration variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-annotation-mode 'html-mode - "*A symbol specifying the major mode to enter when doing annotations.") - -(defvar w3-annotation-position 'bottom - "*A symbol specifying where personal annotations should appear in a buffer. -Can be one of the symbols 'top or 'bottom. If the symbol is eq to 'top, then -the annotations will appear at the top of the buffer. If 'bottom, will appear -at the end of the buffer.") - (defvar w3-auto-image-alt t "*Whether emacs-w3 should create an alt attribute for an image that is missing it. @@ -80,42 +71,18 @@ (defvar w3-default-configuration-file nil "*Where per-user customizations of w3 are kept.") -(defvar w3-default-action 'w3-prepare-buffer - "*A lisp symbol specifying what action to take for files with -extensions that are not mapped to a MIME type in `mm-mime-extensions'. -This is useful in case you ever run across files with weird extensions -\(.foo, .README, .READMEFIRST, etc). This should not be required -anymore. - -Possible values: any lisp symbol. Should be a function that takes no -arguments. The return value does not matter, it is ignored. Some examples -are: - -Action Value ----------------------------------------------- -Parse as HTML 'w3-prepare-buffer -View as text 'indented-text-mode") - (defvar w3-default-homepage nil - "*The url to open at startup. It can be any valid URL. This will -default to the environment variable WWW_HOME if you do not set it in -your .emacs file. If WWW_HOME is undefined, then it will default to -the hypertext documentation for W3 at Indiana University.") + "*The url to open at startup. It can be any valid URL. +This will default to the environment variable WWW_HOME if you do not +set it in your .emacs file. If WWW_HOME is undefined, then it will +default to the hypertext documentation for W3 at Indiana University.") (defvar w3-default-stylesheet nil "*The filename of the users default stylesheet.") -(defvar w3-do-blinking nil - "*Whether emacs-w3 should display blinking text.") - (defvar w3-do-incremental-display nil "*Whether to do incremental display of pages or not.") -(defvar w3-documents-menu-file nil - "*Where the Mosaic documents-menu file is located. This is a file -that has extra menus for the 'Navigate' menu. This should be in the same -format as the Mosaic extra documents.menu.") - (defvar w3-dump-to-disk nil "*If non-nil, all W3 pages loaded will be dumped to disk.") @@ -166,32 +133,12 @@ files in LaTeX. Good defaults are: {article}, [psfig,twocolumn]{article}, etc.") -(defvar w3-link-info-display-function nil - "*A function to call to get extra information about a link and -include it in a buffer. Will be placed after the link and any other -delimiters.") - (defvar w3-mail-command 'mail "*This function will be called whenever w3 needs to send mail. It should enter a mail-mode-like buffer in the current window. -`w3-mail-other-window-command' will be used if w3-mutable-windows is t. The commands `mail-to' and `mail-subject' should still work in this buffer, and it should use mail-header-separator if possible.") -(defvar w3-mail-other-window-command 'mail-other-window - "*This function will be called whenever w3 needs to send mail in -another window. It should enter a mail-mode-like buffer in a -different window. The commands `mail-to' and `mail-subject' should still -work in this buffer, and it should use mail-header-separator if -possible.") - -(defvar w3-max-inlined-image-size nil - "*The maximum byte size of a file to transfer as an inlined image. -If an image is being retrieved and exceeds this size, then it will be -cancelled. This works best on HTTP/1.0 servers that send a -Content-length header, otherwise the image is retrieved up until the -max number of bytes is retrieved, then killed.") - (defvar w3-max-menu-length 35 "*The maximum length of a pulldown menu before it will be split into smaller chunks, with the first part as a submenu, followed by the rest @@ -215,12 +162,6 @@ (defvar w3-mule-attribute 'underline "*How to highlight items in Mule (Multi-Linugual Emacs).") -(defvar w3-mutable-windows nil - "*Controls how new WWW documents are displayed. If this is set to -non-nil and pop-up-windows is non-nil, then new buffers will be shown -in another window. If either is nil, then it will replace the document -in the current window.") - (defvar w3-netscape-configuration-file nil "*A Netscape-for-X style configuration file. This file will only be read if and only if `w3-use-netscape-configuration-file' is non-nil.") @@ -244,19 +185,9 @@ Any other value of `w3-notify' is equivalent to `meek'.") -(defvar w3-personal-annotation-directory nil - "*Directory where w3 looks for personal annotations. -This is a directory that should hold the personal annotations stored in -a Mosaic-compatible format.") - -(defvar w3-ppmtoxbm-command "ppmtopgm | pgmtopbm | pbmtoxbm" - "*The command used to convert from the portable-pixmap graphics format -to an x bitmap. This will only ever be used if XEmacs doesn't have support -for XPM.") - -(defvar w3-ppmtoxpm-command "ppmtoxpm" - "*The command used to convert from the portable-pixmap graphics format -to XPM. The XPM _MUST_ be in version 3 format.") +(defvar w3-popup-menu-on-mouse-3 t + "*Non-nil value means W3 should provide context-sensitive menus on mouse-3. +A nil value means W3 should not change the binding of mouse-3.") (defvar w3-print-command "lpr -h -d" "*Print command for dvi files. @@ -282,29 +213,7 @@ (defvar w3-maximum-line-length nil "*Maximum length of a line. If nil, then lines can extend all the way to -the window margin. If a number, the smaller of this and -(- (window-width) w3-right-margin) is used.") - -(defvar w3-right-justify-address t - "*Whether to make address fields right justified, like Arena.") - -(defvar w3-show-headers nil - "*This is a list of regexps that match HTTP/1.0 headers to show at -the end of a buffer. All the headers being matched against will be -in lowercase. All matching headers will be inserted at the end of the -buffer in a
      list.") - -(defvar w3-show-status t - "*Whether to show a running total of bytes transferred. Can cause a -large hit if using a remote X display over a slow link, or a terminal -with a slow modem.") - -(defvar w3-starting-documents - '(("Internet Starting Points" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/StartingPoints/NetworkStartingPoints.html") - ("Internet Resources Meta-index" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/MetaIndex.html") - ("NCSA's What's New" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Docs/whats-new.html")) - "*An assoc list of titles and URLs for quick access. These are just -defaults so that new users have somewhere to go.") +the window margin.") (defvar w3-temporary-directory "/tmp" "*Where temporary files go.") @@ -315,11 +224,6 @@ (defvar w3-track-mouse t "*Whether to track the mouse and message the url under the mouse.") -(defvar w3-use-forms-index t - "*Non-nil means translate tags into a hypertext form. -A single text entry box will be drawn where the ISINDEX tag appears. -If t, the isindex handling will be the same as Mosaic for X.") - (defvar w3-use-netscape-configuration-file nil "*Whether to use a netscape configuration file to determine things like home pages, link colors, etc. If non-nil, then `w3-netscape-configuration-file' @@ -363,35 +267,8 @@ "*In FSF v19 emacs?") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Link delimiting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-delimit-emphasis 'guess - "*Whether to use characters at the start and end of each bold/italic -region. Obsolete variable (almost) - all this should be specified by the -default stylesheet.") - -(defvar w3-link-start-delimiter '("[[" . "{{") - "*Put this at front of link if w3-delimit-links is t.") - -(defvar w3-link-end-delimiter '("]]" . "}}") - "*Put this at end of link if w3-delimit-links is t.") - -(defvar w3-delimit-links 'guess - "*Put brackets around links? If this variable is eq to 'linkname, then -it will put the link # in brackets after the link text. If it is nil, then -it will not put anything. If it is non-nil and not eq to 'linkname, then -it will put [[ & ]] around the entire text of the link. Is initially set -to be t iff in normal emacs. Nil if in XEmacs or lucid emacs, since links -should be in different colors/fonts.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Graphics parsing stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-graphics-always-show-entities t - "*Set to t to always show graphic entities, regardless of the value of -w3-delay-image-loads. Useful if you keep the entities locally and aren't -worried about the transfer time on something that small.") - (defvar w3-graphics-list nil "*List of graphics already read in.") @@ -426,45 +303,6 @@ ("image/tiff" . tiff) ) "*How to map MIME types to image types for the `image' package.") -(defvar w3-color-use-reducing 'guess - "*Whether to use ppmquant/ppmdither to do color reducing for inlined images. -If you are using a 24bit display, you should set this to nil.") - -(defvar w3-color-max-red 4 - "*Max # of red cells to allocate for inlined images.") - -(defvar w3-color-max-green 4 - "*Max # of green cells to allocate for inlined images.") - -(defvar w3-color-max-blue 4 - "*Max # of blue cells to allocate for inlined images.") - -(defvar w3-color-filter 'ppmdither - "*How to do color reducing on inlined images. -This should be a symbol, either ppmdither or ppmquant. -This variable only has any meaning if w3-color-use-reducing is non-nil. -Possible values are: - -ppmquant :== Use the ppmquant program to reduce colors. The product - of w3-color-max-[red|green|blue] is used as the maximum - number of colors. -ppmdither :== Use the ppmdither program to reduce colors. - -any string :== Use this string as the filter. No interpretation of it - is done at all. Example is: - ppmquant -fs -map ~/pixmaps/colormap.ppm") - -(defvar w3-ppmdither-is-buggy t - "*The ppmdither which comes with pbmplus/netpbm releases through -1mar1994 at least ignores the 'maxval' in its input. This can cause -trouble viewing black-and-white gifs. If this variable is set, a -(harmless) 'pnmdepth 255' step is inserted to work around this bug. -You can test your ppmdither by doing - ppmmake white 100 100 | pnmdepth 1 | ppmdither | pnmdepth 255 | ppmhist -If the output has a single line like this: - 255 255 255 255 10000 -then it's safe to set this variable to nil.") - ;; Store the database of HTML general entities. (defvar w3-html-entities '( @@ -699,19 +537,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Menu definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-navigate-menu nil) (defvar w3-popup-menu '("Emacs-W3 Commands" - ["Back" w3-backward-in-history t] - ["Forward" w3-forward-in-history t] - "---" - ["Add annotation" w3-annotation-add t] + ["Back" w3-history-backward (car (w3-history-find-url-internal (url-view-url t)))] + ["Forward" w3-history-forward (cdr (w3-history-find-url-internal (url-view-url t)))] ) "The shorter popup menu.") -(defvar w3-documentation-root "http://www.cs.indiana.edu/elisp/w3/docs/" - "*Where the w3 documentation lives. This MUST end in a slash.") - (defvar w3-graphlink-menu '(("Open this Image (%s)" . w3-fetch) ("Save this Image As..." . w3-download-url) @@ -736,6 +568,9 @@ the link. Each label can have exactly one `%s' that will be replaced by the URL of the link.") +(defvar w3-documentation-root "http://www.cs.indiana.edu/elisp/w3/docs/" + "*Where the w3 documentation lives. This MUST end in a slash.") + (defvar w3-defined-link-types ;; This is the HTML3.0 list (downcased) plus "made". '("previous" "next" "up" "down" "home" "toc" "index" "glossary" @@ -750,52 +585,6 @@ (defvar w3-form-radio-elements nil "Internal variable - do not touch!") (defvar w3-form-elements nil "Internal variable - do not touch!") -(defvar w3-invisible-href-list nil - "A list of 'invisible' graphic links in the current buffer.") - -(defconst w3-state-locator-variable - '( - :align - :background - :center - :depth - :figalt - :figdata - :fillcol - :form - :formnum - :header-start - :href - :link-args - :image - :lists - :map - :name - :needspace - :next-break - :nofill - :nowrap - :optarg - :options - :pre-start - :select - :secret - :table - :text-mangler - :title - :link-title - :w3-graphic - :zone - :label-text - :seen-this-url - ) - "A list of all the various state kept in the drawing engine. -This is used by the `w3-get-state' and `w3-put-state' macros.") - -(defvar w3-state-vector - (make-vector (1+ (length w3-state-locator-variable)) nil) - "Various state shit kept by emacs-w3.") - (defvar w3-user-stylesheet nil "The global stylesheet for this user.") @@ -819,23 +608,11 @@ "An internal variable for the new display engine that specifies the last tag processed.") -(defvar w3-table-info nil - "An internal variable for the new display engine for keeping table data -during the pre-pass parsing.") - -(defvar w3-current-formatter nil - "Current formatter function.") - -(defvar w3-draw-buffer nil - "Where we are currently drawing into. This _must_ be a buffer object -when it is referenced.") - (defvar w3-active-faces nil "The list of active faces.") (defvar w3-active-voices nil "The list of active voices.") (defvar w3-netscape-variable-mappings '(("PRINT_COLOR" . ps-print-color-p) - ("DITHER_IMAGES" . w3-color-use-reducing) ("SOCKS_HOST" . url-socks-host) ("ORGANIZATION" . url-user-organization) ("EMAIL_ADDRESS" . url-personal-mail-address) @@ -858,13 +635,10 @@ ("Mail session" . "mailto")) "An assoc list of descriptive labels and the corresponding URL stub.") -(defvar w3-annotation-marker "") -(defvar w3-annotation-minor-mode nil "Whether we are in the minor mode.") (defconst w3-bug-address "wmperry@cs.indiana.edu" "Address of current maintainer, where to send bug reports.") (defvar w3-continuation '(url-uncompress url-clean-text) "List of functions to call to process a document completely.") -(defvar w3-current-annotation nil "URL of document we are annotating...") (defvar w3-current-isindex nil "Is the current document a searchable index?") (defvar w3-current-last-buffer nil "Last W3 buffer seen before this one.") (defvar w3-current-links nil "An assoc list of tags for this doc.") @@ -873,13 +647,11 @@ (defvar w3-current-parse nil "Parsed version of current document.") (defconst w3-default-continuation '(url-uncompress url-clean-text) "Default action to start with - cleans text and uncompresses if necessary.") -(defvar w3-editing-annotation nil "Are we editing an annotation or not?") (defvar w3-find-this-link nil "Link to go to within a document.") (defvar w3-hidden-forms nil "List of hidden form areas and their info.") (defvar w3-hotlist nil "Default hotlist.") (defvar w3-icon-path-cache nil "Cache of where we found icons for entities.") (defvar w3-last-buffer nil "The last W3 buffer visited.") -(defvar w3-personal-annotations nil "Assoc list of personal annotations.") (defvar w3-print-next nil "Should we latex & print the next doc?") (defvar w3-roman-characters "ivxLCDMVX" "Roman numerals.") (defvar w3-setup-done nil "Have we been through setup code yet?") @@ -921,7 +693,6 @@ url-current-type url-current-user w3-current-parse - w3-current-annotation w3-current-isindex w3-current-last-buffer w3-current-links @@ -929,8 +700,6 @@ w3-current-source w3-delayed-images w3-hidden-forms - w3-invisible-href-list - w3-state-vector w3-current-stylesheet w3-form-labels w3-id-positions @@ -939,18 +708,6 @@ "A list of variables that should be preserved when entering w3-mode.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Syntax stuff -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-parse-args-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table) - "A syntax table for parsing sgml attributes.") - -(modify-syntax-entry ?' "\"" w3-parse-args-syntax-table) -(modify-syntax-entry ?` "\"" w3-parse-args-syntax-table) -(modify-syntax-entry ?< "(>" w3-parse-args-syntax-table) -(modify-syntax-entry ?> ")<" w3-parse-args-syntax-table) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Emulation stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar w3-netscape-emulation-minor-mode nil @@ -971,17 +728,11 @@ (lambda (var) (if (boundp var) (make-variable-buffer-local var)))) w3-persistent-variables) -(make-variable-buffer-local 'w3-state-vector) -(make-variable-buffer-local 'w3-current-stylesheet) + (make-variable-buffer-local 'w3-base-alist) -(make-variable-buffer-local 'w3-annotation-minor-mode) (make-variable-buffer-local 'w3-last-tag) (make-variable-buffer-local 'w3-last-fill-pos) -(make-variable-buffer-local 'w3-table-info) -(make-variable-buffer-local 'w3-draw-buffer) -(make-variable-buffer-local 'w3-current-formatter) (make-variable-buffer-local 'w3-active-faces) -(make-variable-buffer-local 'w3-default-style) (make-variable-buffer-local 'w3-netscape-emulation-minor-mode) (make-variable-buffer-local 'w3-lynx-emulation-minor-mode) (make-variable-buffer-local 'w3-last-search-item) @@ -991,8 +742,6 @@ ;;; Keymap definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar w3-mode-map (make-keymap) "Keymap to use in w3-mode.") -(defvar w3-annotation-minor-mode-map (make-keymap) "Keymap for annotation.") - (suppress-keymap w3-mode-map) (define-key w3-mode-map "h" (make-sparse-keymap)) @@ -1009,20 +758,16 @@ (define-key w3-mode-map "hI" 'w3-hotlist-add-document-at-point) (define-key w3-mode-map "hR" 'w3-hotlist-refresh) -(define-key w3-mode-map "ai" 'w3-annotation-add) -(define-key w3-mode-map "ad" 'w3-delete-personal-annotation) -(define-key w3-mode-map "ae" 'w3-annotation-edit) - -(define-key w3-mode-map "HF" 'w3-forward-in-history) -(define-key w3-mode-map "HB" 'w3-backward-in-history) +(define-key w3-mode-map "HF" 'w3-history-forward) +(define-key w3-mode-map "HB" 'w3-history-backward) (define-key w3-mode-map "Hv" 'w3-show-history-list) (define-key w3-mode-map " " 'w3-scroll-up) (define-key w3-mode-map "<" 'beginning-of-buffer) (define-key w3-mode-map ">" 'end-of-buffer) (define-key w3-mode-map "?" 'w3-help) -(define-key w3-mode-map "B" 'w3-backward-in-history) -(define-key w3-mode-map "F" 'w3-forward-in-history) +(define-key w3-mode-map "B" 'w3-history-backward) +(define-key w3-mode-map "F" 'w3-history-forward) (define-key w3-mode-map "G" 'w3-show-graphics) (define-key w3-mode-map "I" 'w3-popup-info) (define-key w3-mode-map "K" 'w3-save-this-url) @@ -1065,18 +810,12 @@ (define-key w3-mode-map [(control meta t)] 'url-list-processes) ;; Widget navigation -(define-key w3-mode-map "\t" 'w3-widget-forward) +(define-key w3-mode-map [tab] 'w3-widget-forward) +(define-key w3-mode-map "\M-\t" 'w3-widget-backward) +(define-key w3-mode-map [backtab] 'w3-widget-backward) (define-key w3-mode-map [(shift tab)] 'w3-widget-backward) +(define-key w3-mode-map [(meta tab)] 'w3-widget-backward) -(define-key w3-annotation-minor-mode-map "\C-c\C-c" - 'w3-personal-annotation-finish) - -;;; This is so we can use a consistent method of checking for mule support -;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses -;;; (featurep 'mule) - I choose to use the latter. - -(if (boundp 'MULE) - (provide 'mule)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Keyword definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-widget.el --- a/lisp/w3/w3-widget.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-widget.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-widget.el --- An image widget ;; Author: wmperry -;; Created: 1997/01/17 22:09:43 -;; Version: 1.16 +;; Created: 1997/02/09 06:37:14 +;; Version: 1.18 ;; Keywords: faces, images ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -148,6 +148,37 @@ 'src (widget-get widget 'src) 'ismap server-map))) +(defun widget-image-emacspeak-tty-imagemap (usemap) + (let* ((default nil) + (href nil) + (tag nil) + (options (delete + nil + (mapcar + (function + (lambda (x) + (if (eq (aref x 0) 'default) + (setq default (aref x 2))) + (if (and (not default) (stringp (aref x 2))) + (setq default (aref x 2))) + (setq tag (or (aref x 3) (aref x 2)) + href (aref x 2)) + (and (stringp tag) + (stringp href) + (list 'a + (list + (cons 'href href) + (cons + 'class + (list + (if (url-have-visited-url href) + ":visited" ":link")))) + (list tag))))) + usemap)))) + (w3-display-node (list 'table '((border . "1")) + (w3-display-chop-into-table + (list nil nil options) 3))))) + (defun widget-image-value-create (widget) ;; Insert the printed representation of the value (let ( @@ -177,27 +208,31 @@ (goto-char where) (cond (client-map - (let* ((default nil) - (options (mapcar - (function - (lambda (x) - (if (eq (aref x 0) 'default) - (setq default (aref x 2))) - (if (and (not default) (stringp (aref x 2))) - (setq default (aref x 2))) - (list 'choice-item - :format "%[%t%]" - :tag (or (aref x 3) (aref x 2)) - :value (aref x 2)))) client-map))) - (setq real-widget - (apply 'widget-create 'menu-choice - :tag (or (widget-get widget :tag) "Imagemap") - :notify (widget-get widget :notify) - :action (widget-get widget :action) - :value default - :parent widget - :help-echo 'widget-image-summarize - options)))) + (if (featurep 'emacspeak) + (widget-image-emacspeak-tty-imagemap client-map) + (let* ((default nil) + (href nil) + (tag nil) + (options (mapcar + (function + (lambda (x) + (if (eq (aref x 0) 'default) + (setq default (aref x 2))) + (if (and (not default) (stringp (aref x 2))) + (setq default (aref x 2))) + (list 'choice-item + :format "%[%t%]" + :tag (or (aref x 3) (aref x 2)) + :value (aref x 2)))) client-map))) + (setq real-widget + (apply 'widget-create 'menu-choice + :tag (or (widget-get widget :tag) "Imagemap") + :notify (widget-get widget :notify) + :action (widget-get widget :action) + :value default + :parent widget + :help-echo 'widget-image-summarize + options))))) ((and server-map (stringp href)) (setq real-widget (widget-image-create-subwidget @@ -334,9 +369,10 @@ (lambda (entry) (cons (or (aref entry 3) (aref entry 2)) - (aref entry 3)))) usemap)) + (aref entry 2)))) usemap)) (choice nil)) - (setq choice (completing-read "Imagemap: " choices nil t)) + (setq choice (completing-read "Imagemap: " choices nil t) + choice (cdr-safe (assoc choice choices))) (and (stringp choice) (w3-fetch choice)))) (ismap ; Do server-side dummy imagemap for tty (w3-fetch (concat href "?0,0"))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3-xemac.el --- a/lisp/w3/w3-xemac.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3-xemac.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/19 20:06:02 -;; Version: 1.12 +;; Created: 1997/02/10 16:08:10 +;; Version: 1.14 ;; Keywords: faces, help, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -80,6 +80,24 @@ (if current-menubar (add-submenu '("Help") (cons "WWW" (cdr w3-menu-help-menu)))))) + ;; FIXME FIXME: Do sexy things to the default modeline for Emacs-W3 + + ;; The following is a workaround for XEmacs 19.14 and XEmacs 20.0 + ;; The text property implementation is badly broken - you could not have + ;; a text property with a `nil' value. Bad bad bad. + (if (or (and (= emacs-major-version 20) + (= emacs-minor-version 0)) + (and (= emacs-major-version 19) + (= emacs-minor-version 14))) + (defun text-prop-extent-paste-function (ext from to) + (let ((prop (extent-property ext 'text-prop nil)) + (val nil)) + (if (null prop) + (error "Internal error: no text-prop")) + (setq val (extent-property ext prop nil)) + (put-text-property from to prop val nil) + nil)) + ) ) (defun w3-store-in-clipboard (str) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/w3.el --- a/lisp/w3/w3.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/w3/w3.el Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3.el --- Main functions for emacs-w3 on all platforms/versions ;; Author: wmperry -;; Created: 1997/01/29 06:25:59 -;; Version: 1.61 +;; Created: 1997/02/13 23:05:56 +;; Version: 1.77 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -127,60 +127,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions for compatibility with XMosaic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Parse out the Mosaic documents-menu file -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun w3-parse-docs-menu () - ;; Parse the Mosaic documents menu - (let ((tmp-menu (append '((separator)) w3-starting-documents - '((separator)))) - real-menu x y name url) - (if (or (not (file-exists-p w3-documents-menu-file)) - (not (file-readable-p w3-documents-menu-file))) - nil - (save-excursion - (set-buffer (get-buffer-create " *w3-temp*")) - (erase-buffer) - (insert-file-contents w3-documents-menu-file) - (goto-char (point-min)) - (while (not (eobp)) - (if (not (looking-at "-+$")) - (setq x (progn (beginning-of-line) (point)) - y (progn (end-of-line) (point)) - name (prog1 - (buffer-substring x y) - (delete-region x (min (1+ y) (point-max)))) - x (progn (beginning-of-line) (point)) - y (progn (end-of-line) (point)) - url (prog1 - (buffer-substring x y) - (delete-region x (min (1+ y) (point-max)))) - tmp-menu (if (rassoc url tmp-menu) tmp-menu - (cons (cons name url) tmp-menu))) - (setq tmp-menu (cons '(separator) tmp-menu)) - (delete-region (point-min) (min (1+ (progn (end-of-line) - (point))) - (point-max))))) - (kill-buffer (current-buffer)))) - (if (equal (car (car tmp-menu)) "") (setq tmp-menu (cdr tmp-menu))) - (while tmp-menu - (setq real-menu (cons (if (equal 'separator (car (car tmp-menu))) - "--------" - (vector (car (car tmp-menu)) - (list 'w3-fetch - (if (listp (cdr (car tmp-menu))) - (car (cdr (car tmp-menu))) - (cdr (car tmp-menu)))) t)) - real-menu) - tmp-menu (cdr tmp-menu))) - (setq w3-navigate-menu (append w3-navigate-menu real-menu - (list "-----"))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to pass files off to external viewers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun w3-start-viewer (fname cmd &optional view) @@ -384,9 +330,7 @@ (defun w3-open-local (fname) "Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." +hypertext document." (interactive "FLocal file: ") (setq fname (expand-file-name fname)) (if (not w3-setup-done) (w3-do-setup)) @@ -396,9 +340,7 @@ (defun w3-find-file (fname) "Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." +hypertext document." (interactive "FLocal file: ") (w3-open-local fname)) @@ -560,12 +502,15 @@ (save-excursion (set-buffer url-working-buffer) (if x - (w3-add-urls-to-history x (url-view-url t))) + (w3-history-push x (url-view-url t))) (setq w3-current-last-buffer lastbuf))) (t - (w3-add-urls-to-history x url) + (w3-history-push x url) (w3-sentinel lastbuf) - )))) + (if (string-match "#\\(.*\\)" url) + (progn + (push-mark (point) t) + (w3-find-specific-link (match-string 1 url)))))))) (if w3-track-last-buffer (setq w3-last-buffer buf)) (let ((w3-notify (if (memq w3-notify '(newframe bully @@ -584,59 +529,58 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; History for forward/back buttons ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-node-history nil "History for forward and backward jumping") +(defvar w3-history-stack nil + "History stack viewing history. +This is an assoc list, with the oldest items first. +Each element is a cons cell of (url . timeobj), where URL +is the normalized URL (default ports removed, etc), and TIMEOBJ is +a standard Emacs time. See the `current-time' function documentation +for information on this format.") -(defun w3-plot-course () - "Show a map of where the user has been in this session of W3. !!!!NYI!!!" - (interactive) - (error "Sorry, w3-plot-course is not yet implemented.")) +(defun w3-history-find-url-internal (url) + "Search in the history list for URL. +Returns a cons cell, where the car is the 'back' node, and +the cdr is the 'next' node." + (let* ((node (assoc url w3-history-stack)) + (next (cadr (memq node w3-history-stack))) + (last nil) + (temp nil) + (todo w3-history-stack)) + ;; Last node is a little harder to find without using back links + (while (and (not last) todo) + (if (string= (caar todo) url) + (setq last (or temp 'none)) + (setq temp (pop todo)))) + (cons (if (not (symbolp last)) last) + next))) -(defun w3-forward-in-history () +(defun w3-history-forward () "Go forward in the history from this page" (interactive) - (let* ((thisurl (url-view-url t)) - (node (assoc (if (string= "" thisurl) (current-buffer) thisurl) - w3-node-history)) - (url (cdr node)) - (w3-reuse-buffers 'yes)) - (cond - ((null url) (error "No forward found for %s" thisurl)) - ((and (bufferp url) (buffer-name url)) - (switch-to-buffer url)) - ((stringp url) - (w3-fetch url)) - ((bufferp url) - (setq w3-node-history (delete node w3-node-history)) - (error "Killed buffer in history, removed.")) - (t - (error "Something is very wrong with the history!"))))) + (let ((next (cadr (w3-history-find-url-internal (url-view-url t)))) + (w3-reuse-buffers 'yes)) + (if next + (w3-fetch next)))) -(defun w3-backward-in-history () +(defun w3-history-backward () "Go backward in the history from this page" (interactive) - (let* ((thisurl (url-view-url t)) - (node (rassoc (if (string= thisurl "") (current-buffer) thisurl) - w3-node-history)) - (url (car node)) - (w3-reuse-buffers 'yes)) - (cond - ((null url) (error "No backward found for %s" thisurl)) - ((and (bufferp url) (buffer-name url)) - (switch-to-buffer url)) - ((stringp url) - (w3-fetch url)) - ((bufferp url) - (setq w3-node-history (delete node w3-node-history)) - (error "Killed buffer in history, removed.")) - (t - (error "Something is very wrong with the history!"))))) + (let ((last (caar (w3-history-find-url-internal (url-view-url t)))) + (w3-reuse-buffers 'yes)) + (if last + (w3-fetch last)))) -(defun w3-add-urls-to-history (referer url) +(defun w3-history-push (referer url) "REFERER is the url we followed this link from. URL is the link we got to." - (let ((node (assoc referer w3-node-history))) - (if node - (setcdr node url) - (setq w3-node-history (cons (cons referer url) w3-node-history))))) + (if (not referer) + (setq w3-history-stack (list (cons url (current-time)))) + (let ((node (memq (assoc referer w3-history-stack) w3-history-stack))) + (if node + (setcdr node (list (cons url (current-time)))))))) + +(defalias 'w3-add-urls-to-history 'w3-history-push) +(defalias 'w3-backward-in-history 'w3-history-backward) +(defalias 'w3-forward-in-history 'w3-history-forward) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -763,18 +707,6 @@ string (concat (substring string 0 w3-max-menu-width) "$"))) -(defun w3-use-starting-documents () - "Use the list of predefined starting documents from w3-starting-documents" - (interactive) - (let ((w3-hotlist w3-starting-documents)) - (w3-use-hotlist))) - -(defun w3-show-starting-documents () - "Show the list of predefined starting documents from w3-starting-documents" - (interactive) - (if (not w3-setup-done) (w3-do-setup)) - (w3-fetch "www://auto/starting-points")) - (defun w3-insert-formatted-url (p) "Insert a formatted url into a buffer. With prefix arg, insert the url under point." @@ -784,13 +716,13 @@ (p (setq p (widget-at (point))) (or p (error "No url under point")) - (setq str (format "%s" (widget-get p 'href) + (setq str (format "%s" (widget-get p 'href) (read-string "Link text: " (buffer-substring (widget-get p :from) (widget-get p :to)))))) (t - (setq str (format "%s" (url-view-url t) + (setq str (format "%s" (url-view-url t) (read-string "Link text: " (buffer-name)))))) (setq buff (read-buffer "Insert into buffer: " nil t)) (if buff @@ -817,8 +749,14 @@ (defun w3-widget-button-click (e) (interactive "@e") - (if (widget-at (event-point e)) - (widget-button-click e))) + (cond + ((and (event-point e) + (widget-at (event-point e))) + (widget-button-click e)) + ((and (fboundp 'event-glyph) + (event-glyph e) + (glyph-property (event-glyph e) 'widget)) + (widget-button-click e)))) (defun w3-breakup-menu (menu-desc max-len) (if (> (length menu-desc) max-len) @@ -885,8 +823,6 @@ (x 0) (args command-line-args-left) (w3-strict-width 80) - (w3-delimit-emphasis nil) - (w3-delimit-links nil) (retrieval-function 'w3-fetch) (file-format "text") (header "") @@ -1067,16 +1003,14 @@ (let ((ps-spool-buffer-name " *w3-temp*")) (if (get-buffer ps-spool-buffer-name) (kill-buffer ps-spool-buffer-name)) - (w3-print-with-ps-print (current-buffer) - 'ps-spool-buffer-with-faces) + (ps-spool-buffer-with-faces) (set-buffer ps-spool-buffer-name))) ((equal "PostScript" format) (let ((ps-spool-buffer-name " *w3-temp*")) (if (get-buffer ps-spool-buffer-name) (kill-buffer ps-spool-buffer-name)) (setq content-type "application/postscript") - (w3-print-with-ps-print (current-buffer) - 'ps-spool-buffer-with-faces) + (ps-spool-buffer-with-faces) (set-buffer ps-spool-buffer-name))) ((and under (equal "Formatted Text" format)) (setq content-type "text/plain; charset=iso-8859-1") @@ -1089,25 +1023,18 @@ (setq-default url-be-asynchronous nil) (url-retrieve url) (setq-default url-be-asynchronous old-asynch) - (w3-parse-tree-to-latex (w3-parse-buffer (current-buffer) t) + (w3-parse-tree-to-latex (w3-parse-buffer (current-buffer)) url))) ((equal "LaTeX Source" format) (setq content-type "application/x-latex; charset=iso-8859-1") (w3-parse-tree-to-latex w3-current-parse url))) (buffer-string)))) - (cond - ((and w3-mutable-windows (fboundp w3-mail-other-window-command)) - (funcall w3-mail-other-window-command)) - ((fboundp w3-mail-command) - (funcall w3-mail-command)) - (w3-mutable-windows (mail-other-window)) - (t (mail))) + (funcall w3-mail-command) (mail-subject) (insert format " from URL " url "\n" "Mime-Version: 1.0\n" "Content-transfer-encoding: 8bit\n" "Content-type: " content-type) - (re-search-forward mail-header-separator nil) (forward-char 1) (insert (if (equal "HTML Source" format) @@ -1176,7 +1103,7 @@ (mm-extension-to-mime extn)) nil 5))) (if url-current-mime-viewer (setq cont (append cont '(w3-pass-to-viewer))) - (setq cont (append cont (list w3-default-action)))) + (setq cont (append cont (list 'w3-prepare-buffer)))) cont))) (defun w3-use-links () @@ -1193,17 +1120,11 @@ (cond ((and (or (null url-current-type) (equal url-current-type "file")) (eq major-mode 'w3-mode)) - (if w3-mutable-windows - (find-file-other-window url-current-file) - (find-file url-current-file))) + (find-file url-current-file)) ((equal url-current-type "ftp") - (if w3-mutable-windows - (find-file-other-window - (format "/%s@%s:%s" url-current-user url-current-server - url-current-file)) - (find-file - (format "/%s@%s:%s" url-current-user url-current-server - url-current-file)))) + (find-file + (format "/%s@%s:%s" url-current-user url-current-server + url-current-file))) (t (message "Sorry, I can't get that file so you can alter it.")))) (defun w3-insert-this-url (pref-arg) @@ -1270,20 +1191,6 @@ (interactive) (w3-fetch (concat "www://preview/" (buffer-name)))) -(defun w3-edit-source () - "Edit the html document just retrieved" - (set-buffer url-working-buffer) - (let ((ttl (format "Editing %s Annotation: %s" - (cond - ((eq w3-editing-annotation 'group) "Group") - ((eq w3-editing-annotation 'personal) "Personal") - (t "Unknown")) - (url-basepath url-current-file t))) - (str (buffer-string))) - (set-buffer (get-buffer-create ttl)) - (insert str) - (kill-buffer url-working-buffer))) - (defun w3-source () "Show the source of a file" (let ((tmp (buffer-name (generate-new-buffer "Document Source")))) @@ -1328,7 +1235,8 @@ (if (not (string-match "^www:" (or (url-view-url t) ""))) (w3-convert-code-for-mule url-current-mime-type)) - (let ((x (w3-build-continuation))) + (let ((x (w3-build-continuation)) + (url (url-view-url t))) (while x (funcall (pop x))))) @@ -1377,8 +1285,7 @@ (let ((ps-spool-buffer-name " *w3-temp*")) (if (get-buffer ps-spool-buffer-name) (kill-buffer ps-spool-buffer-name)) - (w3-print-with-ps-print (current-buffer) - 'ps-spool-buffer-with-faces) + (ps-spool-buffer-with-faces) (set-buffer ps-spool-buffer-name))) ((equal "LaTeX Source" format) (w3-parse-tree-to-latex w3-current-parse url) @@ -1501,27 +1408,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to handle formatting an html buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun w3-insert-headers () - ;; Insert some HTTP/1.0 headers if necessary - (url-lazy-message "Inserting HTTP/1.0 headers...") - (let ((hdrs (if (eq t w3-show-headers) (mapcar 'car url-current-mime-headers) - w3-show-headers)) - x y) - (goto-char (setq y (point-max))) - (while hdrs - (if (setq x (w3-in-assoc (car hdrs) url-current-mime-headers)) - (insert "
    • " (car x) ": " (url-insert-entities-in-string - (if (numberp (cdr x)) - (int-to-string (cdr x)) - (cdr x))))) - (setq hdrs (cdr hdrs))) - (if (= y (point-max)) - nil - (insert "
    ") - (goto-char y) - (url-lazy-message "Inserting HTTP/1.0 headers... done.") - (insert "
      ")))) - (defun w3-add-delayed-graphic (widget) ;; Add a delayed image for the current buffer. (setq w3-delayed-images (cons widget w3-delayed-images))) @@ -1737,18 +1623,6 @@ (car (car tmp))) "\n") (setq tmp (cdr tmp))) (insert "\n\t\t\t\n\t\t\n\t\n\n"))) - ((equal type "starting-points") - (let ((tmp w3-starting-documents)) - (insert "\n\t\n\t\t" - " Starting Points \n\t\n" - "\t\n\t\t
      \n\t\t\t

      Starting Point on the Web" - "

      \n\t\t\t
        \n") - (while tmp - (insert (format "\t\t\t\t
      1. %s
        2. \n" - (car (cdr (car tmp))) - (car (car tmp)))) - (setq tmp (cdr tmp))) - (insert "\n\t\t\t
      \n\t\t
      \n\t\n\n"))) ((equal type "history") (if (not url-history-list) (url-retrieve "www://error/nohist") @@ -1910,6 +1784,8 @@ (message "%s" (url-truncate-url-for-viewing href))) (no-show nil) + (widget + (widget-echo-help (point))) (t nil)))) @@ -2232,8 +2108,6 @@ (add-minor-mode 'w3-netscape-emulation-minor-mode " NS" w3-netscape-emulation-minor-mode-map) - (add-minor-mode 'w3-annotation-minor-mode " Annotating" - w3-annotation-minor-mode-map) (add-minor-mode 'w3-lynx-emulation-minor-mode " Lynx" w3-lynx-emulation-minor-mode-map) @@ -2241,55 +2115,21 @@ url-package-name "Emacs-W3") (w3-emit-image-warnings-if-necessary) - (if (eq w3-color-use-reducing 'guess) - (setq w3-color-use-reducing - (cond - ((eq (device-type) 'tty) nil) - ((fboundp 'device-class) - (not (and (memq (device-class) '(TrueColor true-color)) - (<= 16 (or (device-bitplanes) 0))))) - (t t)))) (cond ((memq system-type '(ms-dos ms-windows)) - (setq w3-documents-menu-file (or w3-documents-menu-file - (expand-file-name "~/mosaic.mnu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/mosaic.hot")) - w3-personal-annotation-directory (or w3-personal-annotation-directory - (expand-file-name - "~/mosaic.ann")))) + )) ((memq system-type '(axp-vms vax-vms)) - (setq w3-documents-menu-file - (or w3-documents-menu-file - (expand-file-name "decw$system_defaults:documents.menu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/mosaic.hotlist-default")) - w3-personal-annotation-directory - (or w3-personal-annotation-directory - (expand-file-name "~/mosaic-annotations/")))) + )) (t - (setq w3-documents-menu-file - (or w3-documents-menu-file - (expand-file-name "/usr/local/lib/mosaic/documents.menu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/.mosaic-hotlist-default")) - w3-personal-annotation-directory - (or w3-personal-annotation-directory - (expand-file-name "~/.mosaic-personal-annotations"))))) + ))) - (if (eq w3-delimit-emphasis 'guess) - (setq w3-delimit-emphasis - (and (not w3-running-xemacs) - (not (and w3-running-FSF19 - (memq (device-type) '(x ns pm))))))) - - (if (eq w3-delimit-links 'guess) - (setq w3-delimit-links - (and (not w3-running-xemacs) - (not (and w3-running-FSF19 - (memq (device-type) '(x ns pm))))))) - ; Set up a hook that will save the history list when ; exiting emacs (add-hook 'kill-emacs-hook 'w3-kill-emacs-func) @@ -2300,9 +2140,6 @@ ; Load in the hotlist if they haven't set it already (or w3-hotlist (w3-parse-hotlist)) - ; Load in their personal annotations if they haven't set them already - (or w3-personal-annotations (w3-parse-personal-annotations)) - ; Set the default home page, honoring their defaults, then ; the standard WWW_HOME, then default to the documentation @ IU (or w3-default-homepage @@ -2310,9 +2147,6 @@ (or (getenv "WWW_HOME") "http://www.cs.indiana.edu/elisp/w3/docs.html"))) - ; Set up the documents menu - (w3-parse-docs-menu) - ; Set up the entity definition for PGP and PEM authentication (run-hooks 'w3-load-hook) @@ -2483,6 +2317,7 @@ (run-hooks 'w3-mode-hook) (widget-setup) (setq url-current-passwd-count 0 + inhibit-read-only nil truncate-lines t mode-line-format w3-modeline-format) (if (and w3-current-isindex (equal url-current-type "http")) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/w3/widget-edit.el --- a/lisp/w3/widget-edit.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2187 +0,0 @@ -;;; widget-edit.el --- Functions for creating and using widgets. -;; -;; Copyright (C) 1996 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen -;; Keywords: extensions -;; Version: 1.22 -;; 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) - (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 (widget-get widget :keymap)) - (secret (widget-get widget :secret)) - (secret-to to) - (size (widget-get widget :size)) - (face (or (widget-get widget :value-face) - 'widget-field-face))) - - (when secret - (while (and size - (not (zerop size)) - (> secret-to from) - (eq (char-after (1- secret-to)) ?\ )) - (setq secret-to (1- secret-to))) - - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (get-text-property (point) 'secret))) - (when old - (subst-char-in-region (point) (1+ (point)) secret old))) - (forward-char)))) - - (set-text-properties from to (list 'field widget - 'read-only nil - 'keymap map - 'local-map map - 'face face)) - - (when secret - (save-excursion - (goto-char from) - (while (< (point) secret-to) - (let ((old (following-char))) - (subst-char-in-region (point) (1+ (point)) old secret) - (put-text-property (point) (1+ (point)) 'secret old)) - (forward-char)))) - - (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.") - -(unless widget-keymap - (setq widget-keymap (make-sparse-keymap)) - (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) - -(defvar widget-field-keymap nil - "Keymap used inside an editable field.") - -(unless widget-field-keymap - (setq widget-field-keymap (copy-keymap widget-keymap)) - (define-key widget-field-keymap "\C-m" 'widget-field-activate) - (set-keymap-parent widget-field-keymap global-map)) - -(defvar widget-text-keymap nil - "Keymap used inside a text field.") - -(unless widget-text-keymap - (setq widget-text-keymap (copy-keymap widget-keymap)) - (set-keymap-parent widget-text-keymap global-map)) - -(defun widget-field-activate (pos &optional event) - "Activate the ediable field at point." - (interactive "@d") - (let* ((field (get-text-property pos 'field))) - (if field - (widget-apply field :action event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) - -(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 - :keymap widget-field-keymap - :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)) - (secret (widget-get widget :secret)) - (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))) - (let ((result (buffer-substring-no-properties from to))) - (when secret - (let ((index 0)) - (while (< (+ from index) to) - (aset result index - (get-text-property (+ from index) 'secret)) - (setq index (1+ index))))) - (set-buffer old) - result)) - (widget-get widget :value)))) - -(defun widget-field-match (widget value) - ;; Match any string. - (stringp value)) - -;;; The `text' Widget. - -(define-widget 'text 'editable-field - :keymap widget-text-keymap - "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 498bf5da1c90 -r 0d2f883870bc lisp/w3/widget.el --- a/lisp/w3/widget.el Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; 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.22 -;; 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 :secret :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 498bf5da1c90 -r 0d2f883870bc lisp/x11/x-menubar.el --- a/lisp/x11/x-menubar.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/x11/x-menubar.el Mon Aug 13 09:13:56 2007 +0200 @@ -132,6 +132,7 @@ ["Towers of Hanoi" hanoi t] ["Game of Life" life t] ["Multiplication Puzzle" mpuz t] + ["Mine Game" mine t] ) ) @@ -653,6 +654,7 @@ ["No Warranty" describe-no-warranty t] ["XEmacs License" describe-copying t] ["The Latest Version" describe-distribution t]) + ,custom-help-menu ) ))) diff -r 498bf5da1c90 -r 0d2f883870bc lisp/x11/x-toolbar.el --- a/lisp/x11/x-toolbar.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/x11/x-toolbar.el Mon Aug 13 09:13:56 2007 +0200 @@ -25,52 +25,85 @@ ;; order to get different behaviour. ;; +(defvar toolbar-open-function 'find-file + "*Function to call when the open icon is selected.") + (defun toolbar-open () (interactive) - (call-interactively 'find-file)) + (call-interactively toolbar-open-function)) + +(defvar toolbar-dired-function 'dired + "*Function to call when the dired icon is selected.") (defun toolbar-dired () (interactive) - (call-interactively 'dired)) + (call-interactively toolbar-dired-function)) + +(defvar toolbar-save-function 'save-buffer + "*Function to call when the save icon is selected.") (defun toolbar-save () (interactive) - (call-interactively 'save-buffer)) + (call-interactively toolbar-save-function)) + +(defvar toolbar-print-function 'lpr-buffer + "*Function to call when the print icon is selected.") (defun toolbar-print () (interactive) - (call-interactively 'lpr-buffer)) + (call-interactively toolbar-print-function)) + +(defvar toolbar-cut-function 'x-kill-primary-selection + "*Function to call when the cut icon is selected.") (defun toolbar-cut () (interactive) - (call-interactively 'x-kill-primary-selection)) + (call-interactively toolbar-cut-function)) + +(defvar toolbar-copy-function 'x-copy-primary-selection + "*Function to call when the copy icon is selected.") (defun toolbar-copy () (interactive) - (call-interactively 'x-copy-primary-selection)) + (call-interactively toolbar-copy-function)) + +(defvar toolbar-paste-function 'x-yank-clipboard-selection + "*Function to call when the paste icon is selected.") (defun toolbar-paste () (interactive) - (call-interactively 'x-yank-clipboard-selection)) + (call-interactively toolbar-paste-function)) + +(defvar toolbar-undo-function 'undo + "*Function to call when the undo icon is selected.") (defun toolbar-undo () (interactive) - (call-interactively 'undo)) + (call-interactively toolbar-undo-function)) + +(defvar toolbar-replace-function 'query-replace + "*Function to call when the replace icon is selected.") (defun toolbar-replace () (interactive) - (call-interactively 'query-replace)) + (call-interactively toolbar-replace-function)) ;; ;; toolbar ispell variables and defuns ;; +(defvar toolbar-ispell-function + (lambda () + (interactive) + (if (region-active-p) + (ispell-region (region-beginning) (region-end)) + (ispell-buffer))) + "*Function to call when the ispell icon is selected.") + (defun toolbar-ispell () "Intelligently spell the region or buffer." (interactive) - (if (region-active-p) - (ispell-region (region-beginning) (region-end)) - (ispell-buffer))) + (call-interactively toolbar-ispell-function)) ;; ;; toolbar mail variables and defuns @@ -95,7 +128,7 @@ used to start it.") (defvar toolbar-mail-reader 'vm - "Mail reader toolbar will invoke. + "*Mail reader toolbar will invoke. The legal values are `vm' and `gnus', but you can add your own values by customizing `toolbar-mail-commands-alist'.") @@ -159,6 +192,28 @@ ;; toolbar news variables and defuns ;; +(defvar toolbar-news-commands-alist + `((gnus . gnus) ; M-x all-hail-gnus + (rn . ,(toolbar-external "xterm" "-e" "rn")) + (nn . ,(toolbar-external "xterm" "-e" "nn")) + (trn . ,(toolbar-external "xterm" "-e" "trn")) + (xrn . ,(toolbar-external "xrn")) + (slrn . ,(toolbar-external "xterm" "-e" "slrn")) + (pine . ,(toolbar-external "xterm" "-e" "pine")) ; *gag* + (tin . ,(toolbar-external "xterm" "-e" "tin")) ; *gag* + (netscape . ,(toolbar-external "netscape" "news:"))) + "Alist of news readers and their commands. +Each list element is a pair. The car of the pair is the mail +reader, and the cdr is the form used to start it.") + +(defvar toolbar-news-reader 'gnus + "*News reader toolbar will invoke. +The legal values are gnus, rn, nn, trn, xrn, slrn, pine and netscape. +You can add your own values by customizing `toolbar-news-commands-alist'.") + +(defvar toolbar-news-use-separate-frame t + "*Whether Gnus is invoked in a separate frame.") + (defvar toolbar-news-frame nil "The frame in which news is displayed.") @@ -293,3 +348,5 @@ (x-init-specifier-from-resources right-toolbar-width 'natnum locale '("rightToolBarWidth" . "RightToolBarWidth"))) + +;;; x-toolbar.el ends here diff -r 498bf5da1c90 -r 0d2f883870bc man/ChangeLog --- a/man/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/man/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,20 @@ +Wed Feb 12 12:30:27 1997 Yotam Medini + + * mule/languages.texi: Correct typo. + +Mon Feb 10 08:17:22 1997 Steven L Baur + + * Makefile (srcs): Add custom and widget to srcs. + + * lispref/extents.texi (Intro to Extents): Removed erroneous + reference to `start-glyph' property. + +Sun Feb 9 00:27:22 1997 Per Abrahamsen + + * widget.texi: New file. + + * custom.texi: New file. + Thu Feb 6 22:57:09 1997 Steven L Baur * lispref/extents.texi (Duplicable Extents): replicable extents diff -r 498bf5da1c90 -r 0d2f883870bc man/Makefile --- a/man/Makefile Mon Aug 13 09:12:43 2007 +0200 +++ b/man/Makefile Mon Aug 13 09:13:56 2007 +0200 @@ -32,10 +32,10 @@ makeinfo -o $@ $< # hyperbole and oo-browser manuals broken - do not TeX properly -srcs = ange-ftp cc-mode cl dired ediff external-widget forms gnus \ +srcs = cc-mode cl custom ediff external-widget forms gnus \ hyperbole ilisp info ispell mailcrypt message mh-e oo-browser \ pcl-cvs psgml psgml-api rmail standards supercite term \ - termcap texinfo vhdl-mode viper vm w3 xemacs-faq + termcap texinfo vhdl-mode viper vm w3 widget xemacs-faq info = $(srcs:%=../info/%.info) dvi = $(srcs:%=%.dvi) diff -r 498bf5da1c90 -r 0d2f883870bc man/ange-ftp.texi --- a/man/ange-ftp.texi Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1397 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@comment %**start of header (This is for running Texinfo on a region.) -@setfilename ../info/ange-ftp.info -@settitle ange-ftp -@comment %**end of header (This is for running Texinfo on a region.) - -@synindex pg vr - -@node Top, What is ange-ftp?, (dir), (dir) -@comment node-name, next, previous, up -@ifinfo -@unnumbered Ange-ftp - -This file documents ange-ftp, a system for transparent file-transfer -between remote hosts using the FTP protocol within GNU Emacs. - -This info is current to Version 4.2 of Ange-ftp. - -Documentation version: 1.32 - -Copyright @copyright{} 1991, 1992 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries a copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. -@end ifinfo - -@titlepage -@sp5 -@center @titlefont{ange-ftp} -@center version 4.2 -@sp2 -@center A transparent remote file system, by Andy Norman -@sp7 -@center This documentation by David Smith. -@center info-version 1.32 -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1991, 1992 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. -@end titlepage - -@menu -* What is ange-ftp?:: A brief introduction to ange-ftp. Credits. -* Installing ange-ftp:: Where to find it, and how to use it. -* Using ange-ftp:: Ange-ftp -- a users' guide. -* Getting help:: Mailing lists and newsgroups. -* Bugs:: Known bugs, and a wish list. - -Indices: -* Concept Index:: -* Variable and command index:: -@end menu - - -@node What is ange-ftp?, Installing ange-ftp, Top, Top -@comment node-name, next, previous, up -@chapter Introducing ange-ftp. - -Ange-ftp is a system for transparent file-transfer between remote UNIX, -VMS, CMS or MTS -hosts using FTP. This means that you can edit, copy and otherwise -manipulate files on any machine you have access to from within GNU Emacs -as if it were a local file. Ange-ftp works by introducing an extended -filename syntax, and overloading functions such as -@code{insert-file-contents} so that accessing a remote file causes -appropriate commands to be sent to an FTP process. Ange-ftp works with -Dired (and in particular Sebastian Kremer's Tree Dired) to facilitate -directory browsing and multiple file transfer from remote hosts. - -The author of ange-ftp is Andy (Ange) Norman (@code{ange@@hplb.hpl.hp.com}). -@ifinfo -Many people have sent in enhancements, and Ange has been kept quite -busy testing them and incorporating them into ange-ftp. Current members -of the Ange-Ftp Hall of Fame include: - -@itemize @bullet -@item -Many thanks to Roland McGrath for improving the filename syntax handling, -for suggesting many enhancements and for numerous cleanups to the code. - -@item -Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways. - -@item -Thanks to Ken Laprade for improved @file{.netrc} parsing and password -reading, and Dired/shell autoloading. - -@item -Thanks to Sebastian Kremer for tree dired support and for many ideas and -bugfixes. - -@item -Thanks to Joe Wells for bugfixes, non-UNIX system support, VOS support, -and hostname completion. - -@item -Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help -with file-name expansion, efficiency worries, stylistic concerns and many -bugfixes. - -@item -Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS, -MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and -auto-recognition of the host type. - -@item -Also, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, -Ping Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd -Kaufmann, Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl -Edman, Bill Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve -Anderson, Sanjay Mathur, the folks on the ange-ftp-lovers mailing list -and many others whose names have been forgotten who have helped to debug -and fix problems with @file{ange-ftp.el}. -@end itemize -@end ifinfo - -Finally, this info file was written by Dave Smith -(@code{dsmith@@stats.adelaide.edu.au}), although large chunks of it -@ifinfo -@noindent -(such as most of this node :-) -@end ifinfo -@noindent -are plagiarised straight out of the extensive -comments section of @file{ange-ftp.el}. - -@node Installing ange-ftp, Using ange-ftp, What is ange-ftp?, Top -@comment node-name, next, previous, up -@chapter Installing ange-ftp - -If you don't already have a copy of ange-ftp, or you want a later -version, ange-ftp is pretty easy to get hold of. FTP is the probably the -simplest method, but other options such as mail are available. - -Once you have the Emacs-Lisp source, there are a few customisations you -might need to make. The ideal configuration is to have the FTP process running -on the same machine as you are running Emacs on, but this is not always -possible since some machines cannot access hosts outside the local -network. In this case, the FTP process needs to be run on a machine -which @emph{does} have access to the local world --- this is called the -@strong{gateway host}. Ange-ftp has facilities to make use of a -gateway host when accessing remote hosts. - -@menu -* Obtaining source code:: Where to find the ange-ftp source. -* Installing source:: Where to put it, how to load it. -* Using a gateway:: For when your local machine has limited access. -* Other options:: More user variables to twiddle. -@end menu - -@node Obtaining source code, Installing source, ,Installing ange-ftp -@section How to get the ange-ftp source code -@comment node-name, next, previous, up - -The latest version of ange-ftp should always be available for anonymous -FTP from -@example -alpha.gnu.ai.mit.edu -@end example -@noindent -in the file -@example -ange-ftp/ange-ftp.tar.Z -@end example -@noindent -(which includes both @file{ange-ftp.el} and this texinfo file.) In ange-ftp -notation, that's -@example -/anonymous@@alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.Z -@end example - -Alternatively, ange-ftp is also part of the Emacs-Lisp Archive -@cindex Emacs-Lisp Archive -on -@code{archive.cis.ohio-state.edu}. The latest version should always be -available on this site, but the Lisp-Code Directory entry is not always -up to date; it currently reads: -@example -ange-ftp (3.112) 91-08-12 - Andy Norman, - archive.cis.ohio-state.edu: - /pub/gnu/emacs/elisp-archive/as-is/ange-ftp.el.Z -transparent FTP Support for GNU Emacs -@end example - -Ange-ftp can also be found at: -@example -ugle.unit.no:/pub/gnu/emacs-lisp/ange-ftp.el.Z -@end example - -Failing these, someone on the ange-ftp mailing list (@xref{Getting -help}) or the author himself (@xref{What is ange-ftp?}) may be able to -help you find the latest version. - -If you intend to do a lot of browsing though archive sites it is -definitely worth your while installing Sebastian Kremer's Tree Dired -@cindex Tree Dired, source -along with ange-ftp (if you haven't done it already). Tree Dired will -work with ange-ftp without any modifications: all you need to do is -follow the installation instructions that come with the package. The -Tree Dired package comes complete with the latest version of ange-ftp, -and is available for anonymous FTP from the following sites: -@example -ftp.thp.Uni-Koeln.DE:/pub/gnu/emacs/diredall.tar.Z (134.95.64.1) -ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z -@end example -@noindent -Alternatively, you can get in touch with Sebastian himself -using his e-mail address: @code{sk@@thp.Uni-Koeln.DE}. - -@node Installing source, Using a gateway, Obtaining source code, Installing ange-ftp -@comment node-name, next, previous, up -@section Installing the source - -Installation is simply a matter of copying the file @file{ange-ftp.el} -to a directory in your load-path. If you don't already have a load-path, -this is probably a good time to make one. Just create a directory (say, -@file{~/elisp}) in which you plan to keep your Emacs-Lisp files. Then -place the following line in your @file{.emacs}: -@example -(setq load-path (cons (expand-file-name "~/elisp") load-path)) -@end example -@cindex load path -@noindent -The @code{expand-file-name} is @emph{important} --- omitting it is a -common reason why load-paths do not work. - -Once you've copied @file{ange-ftp.el} to the appropriate directory, it is -recommended to byte-compile it, with @kbd{M-x byte-compile-file}. Then -place the line -@example -(require 'ange-ftp) -@end example -@noindent -in your @file{.emacs} (@emph{after} the line which modifies your -load-path, of course!) It's that simple. - -The above instructions should allow you to access all hosts that your -local machine can access. If your local host has limited access, -however, you may wish to have ange-ftp working through a gateway -machine. If so, read on. Otherwise, @xref{Using ange-ftp} to get started -using ange-ftp. - -@node Using a gateway, Other options, Installing source, Installing ange-ftp -@comment node-name, next, previous, up -@section Using a gateway - -Suppose you are running Emacs (and ange-ftp, of course) on a machine X -(let's call it the `local host') and you want to access a file on a -machine Z (which we will call the `remote host'). Unfortunately, X does -not have FTP access to Z: when you try a manual FTP something like -the following happens: -@example -X$ ftp Z.foo.bar.com -ftp: connect: Host is unreachable -@end example -@noindent -However, X @emph{does} have access to a machine Y (the `gateway -machine') which @emph{can} access Z. Fortunately, you have an account on -the gateway machine, and so the solution is to login to Y, ftp to Z, -download the file you want from Z to Y, and then copy it from Y to the -local host, X. This can get a bit tedious, to say the least, but -fortunately ange-ftp can do all the hard work for you. - -Firstly, you need to set the variable @code{ange-ftp-gateway-host} to -the name of the gateway machine. The name should be the one that the -local host recognises, that is, the name you use with @code{login} so -that it works. -@example -(setq ange-ftp-gateway-host "Y.local.lan.edu") -@end example -@vindex ange-ftp-gateway-host -@noindent -Since you only need to go through these convolutions for remote hosts -that the local host can't access directly, you can set the variable -@code{ange-ftp-local-host-regexp} to a regular expression which matches -those hostnames that X can access, but does not match those hosts that -only the gateway can access. In other words, if the host you are trying -to access matches @code{ange-ftp-local-host-regexp}, the FTP process -will be run on the local machine, otherwise it will be run on the -gateway machine. For example -@example -(setq ange-ftp-local-host-regexp "\\.hp\\.com$\\|^[^.]*$") -@end example -@vindex ange-ftp-local-host-regexp -@noindent -will match all hosts that are in the @samp{.hp.com} domain, or don't have an -explicit domain in their name, but will fail to match hosts with -explicit domains or that are specified by their IP address. - -The next step is to determine whether you have a smart gateway, that is, -@cindex smart gateways -if the FTP process on the gateway will accept commands of the form -@code{USER user@@host}. You can test this by trying a manual FTP: -@example -X$ ftp -n Y.local.lan.edu -Connected to Y.local.lan.edu -220 Y.local.lan.edu FTP server (Version ?.??? some-date) ready. -ftp> user myname@@Z.foo.bar.com -@end example -@noindent -If you then got a message like: -@example -331 Password required for myname@@Z.foo.bar.com -Password: -530 Login incorrect. -Login failed. -@end example -@noindent -then you @emph{don't} have a smart gateway. If you do, then something -else happens -- but since it doesn't work for me I can't say what! -Anyway, if you do have a smart gateway, put the line -@example -(setq ange-ftp-smart-gateway t) -@end example -@vindex ange-ftp-smart-gateway -@noindent -in your @file{.emacs}. You may also wish to set the variable -@code{ange-ftp-smart-gateway-port} -@vindex ange-ftp-smart-gateway-port -to the port of the gateway machine to -use when smart gateway is in operation, but the default of 21 will -probably be fine. In any case, your installation has finished, so -@xref{Using ange-ftp} now -- the rest of this section is of no use to -you. If on the other hand you don't have a smart gateway, put the line -@example -(setq ange-ftp-smart-gateway nil) ; this is the default -@end example -@noindent -in your @file{.emacs} and read on. - -Since to get files from Z to X we need to copy from Z to Y, and then -from Y to X, we need a place to store files on Y which is also -accessible by X, i.e. we need a directory which is mounted on both X and -Y. Since we are assuming that the local host and the gateway machine are -on the same local network, it's fairly likely that this is the case -thanks to NFS. -@cindex NFS -If such a directory exists, then ange-ftp can transfer files from Z to X -simply by FTP'ing from Z to the temporary directory on Y, and then using -a normal (local) copy from the image of the temporary directory on X to -the destination directory. Unfortunately, ange-ftp requires that -this temporary directory -@cindex temporary files -has the @emph{same} name on both the local and -gateway machines, so you might need to do some twiddling with symbolic -links, or ask your sysadmin to set something up with NFS. Once you have -found such a directory, set the variable -@code{ange-ftp-gateway-tmp-name-template} -to the name of this directory plus an identifying filename prefix. For example: -@example -(setq ange-ftp-gateway-tmp-name-template "/nfs/hplose/ange/ange-ftp") -@end example -@vindex ange-ftp-gateway-tmp-name-template -@noindent -where @file{/nfs/hplose/ange} is a directory that is shared between the gateway -machine Y and the local machine X. - -The next step is to find a means of getting an FTP process running on -the gateway machine. The simplest method is to spawn a remote shell -@cindex remote shell -using @code{remsh} or @code{rsh} or their equivalent. Unfortunately, this -doesn't always work --- try the following: -@example -X$ rsh Y.local.lan.edu ftp -@end example -@noindent -On my system, this command simply hangs. On others, it might be -disallowed for security reasons. If it doesn't work for you, then skip -the rest of this paragraph. If it does, then you should set then -variable @code{ange-ftp-gateway-program} to the name of the program -used to spawn a remote shell. The default is @code{"remsh"} -on HP-UX machines, and @code{"rsh"} otherwise. You should also set -@code{ange-ftp-gateway-program-interactive} to @code{nil}: -@example -(setq ange-ftp-gateway-program "rsh") -(setq ange-ftp-gateway-program-interactive nil) -@end example -@vindex ange-ftp-gateway-program -@vindex ange-ftp-gateway-program-interactive -@noindent -and now your installation is complete. - -Since spawning a remote shell didn't work, ange-ftp needs to actually -login to the gateway machine to run ftp, the same as you would do if you -were running ftp manually. So you need to set the variable -@code{ange-ftp-gateway-program} to the name of the program that lets you -log onto the gateway machine --- probably @code{"rlogin"} or @code{"telnet"}: -@example -(setq ange-ftp-gateway-program "rlogin") -@end example -@noindent -Now set the variable @code{ange-ftp-gateway-prompt-pattern} to a regular -expression that matches the prompt you get when you login to the gateway -machine. Be very specific here; this regexp must not match -@emph{anything} in your login banner except this prompt. -@code{shell-prompt-pattern} -@vindex shell-prompt-pattern -is far too general as it appears to match -some login banners from Sun machines. For example: -@example -(setq ange-ftp-gateway-prompt-pattern "^[^$]*\\$ *") -@end example -@vindex ange-ftp-gateway-prompt-pattern -@noindent -You also need to set the variable -@code{ange-ftp-gateway-program-interactive} -to @code{t} to let ange-ftp know that it has to "hand-hold" the login to -the gateway machine: -@example -(setq ange-ftp-gateway-program-interactive t) -@end example -@noindent -Now comes a slightly tricky bit. You need to set the variable -@code{ange-ftp-gateway-setup-term-command} to a UNIX command that will -put the pty connected to the gateway machine into a no-echoing mode, and -will strip off carriage-returns from output from the gateway machine. -The default is @code{"stty -onlcr -echo\n"} for HP-UX machines, and -@cindex HP-UX -@code{"stty -echo nl\n"} otherwise. So -@example -(setq ange-ftp-gateway-setup-term-command "stty -echo nl\n") -@end example -@vindex ange-ftp-gateway-setup-term-command -@noindent -will probably work. If it does, then you're done. There's a bit of a -problem for @code{tcsh} -@cindex tcsh -users, though: in some versions of @code{tcsh}, the "tty -sanity checking" feature prevents the above commands from working. In -this case, an easy fix is to invoke @code{csh} first, and then run the -@code{stty}: -@example -(setq ange-ftp-gateway-setup-term-command "exec csh\nstty -echo nl\n") -@end example -or maybe -@example -(setq ange-ftp-gateway-setup-term-command "(stty -echo nl; csh)\n") -@end example -@noindent -may well do the trick. When using this method, synchronisation may be a -problem: if your gateway machine is slow in responding, when ange-ftp is -ready for (and indeed has already sent) FTP commands, your machine may -still be setting up. This can cause ange-ftp to think that the FTP has -had an error, and abort. One solution is to set -@code{ange-ftp-skip-msgs} -@vindex ange-ftp-skip-msgs -(a regular expression matching messages from the ftp process that can be -ignored) so that any line ending in @code{^M} (carriage-returns) will be -ignored (since the @code{stty} hasn't come into effect yet) and also to -ignore any lines beginning with your prompt (since this means the -terminal setup is still in progress): -@example -(setq ange-ftp-skip-msgs - (concat "\\|^.*\C-M$\\|" ange-ftp-gateway-prompt-pattern - ange-ftp-skip-msgs)) -@end example -@noindent -Unfortunately, this can also mean that sometimes ange-ftp won't -recognise a @emph{real} error, and simply hang -- but if that ever -happens @kbd{C-g} might get you out of it. - -@node Other options, , Using a gateway, Installing ange-ftp -@comment node-name, next, previous, up -@section Other user options - -Here are the other user options available in ange-ftp: - -@code{ange-ftp-netrc-filename}: The name of a file in @code{netrc(5)} -format that ange-ftp will use to match hostnames, users and their -respective passwords. Hostnames specified here are also used for hostname -completion. -The default is @code{"~/.netrc"}. -@vindex ange-ftp-netrc-filename - -@code{ange-ftp-default-user}: If this is a string, it is the username to -use when none is specified in a filename. If @code{nil}, then the -name under which the user is logged in is used. If non-@code{nil} but -not a string, the user is prompted for the name. The default is @code{nil}. -@vindex ange-ftp-default-user - -@code{ange-ftp-default-password}: The password to use when the user is the -same as @code{ange-ftp-default-user}. The default is @code{nil}. -@vindex ange-ftp-default-password - -@code{ange-ftp-default-account}: Account password to use when the user -is the same as @code{ange-ftp-default-user}. The default is @code{nil}. -@vindex ange-ftp-default-account - -@code{ange-ftp-generate-anonymous-password}: If this is @code{t}, then -ange-ftp will generate a password of the form @code{your_username@@local_host} -when you specify a username of @code{anonymous} in the filename (or if -you are automatically logged in as @code{anonymous}). If this is a -string, then that string is used instead. If it is @code{nil}, then the -user is prompted for a password. The default is @code{nil}. -@vindex ange-ftp-generate-anonymous-password - -@code{ange-ftp-dumb-unix-host-regexp}: The FTP servers on some machines have -problems if the @code{ls} command is used. The usual indication that -something is wrong is when ange-ftp erroneously thinks that a directory -is just a plain file. The routine @code{ange-ftp-add-dumb-unix-host} can -be called to tell ange-ftp to limit itself to the @code{DIR} command and -not @code{ls} for a given host (but this change will take effect for the -current GNU Emacs session only). If a large number of machines with -similar hostnames have this problem then it is easier to change the -value of this variable to a regexp which matches hostnames which have -this problem, particularly since ange-ftp cannot automatically detect -such hosts. The default is @code{nil}. -@vindex ange-ftp-dumb-unix-host-regexp -@pindex ange-ftp-add-dumb-unix-host - -@code{ange-ftp-binary-file-name-regexp}: By default ange-ftp will -transfer files in ASCII mode. If a file being transferred matches the -value of this regexp then the FTP process will be toggled into BINARY -mode before the transfer and back to ASCII mode after the transfer. The -default is: -@example -(concat "\\.Z$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" - "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|" - "\\.gif$\\|\\.EXE\\(;[0-9]+\\)?$") -@end example -@vindex ange-ftp-binary-file-name-regexp - -@code{ange-ftp-hash-mark-size}: Ange-ftp by default requests that the -FTP process sends hash marks (just @code{#} characters) during transfers -to keep track of how much data has been sent or received. This variable, -if non-@code{nil}, should be the number of kilobytes represented by the -FTP client's hash mark. The default value of 1 doesn't work for me --- I -use 2 instead. -@vindex ange-ftp-hash-mark-size - -@code{ange-ftp-process-verbose}: If this is @code{t} then ange-ftp will -be chatty about interaction with the FTP process. The default is @code{t}. -@vindex ange-ftp-process-verbose - -@code{ange-ftp-ftp-program-name}: This should be the name of the FTP -program to run on the local host. The default value of @code{"ftp"} -should be fine for most systems. -@vindex ange-ftp-ftp-program-name - -@code{ange-ftp-gateway-ftp-program-name}: Same as above, but this time -it's the name of the program to be used if a gateway is in use. The -default is again @code{"ftp"}, but some AT&T folks claim to use -something called @code{"pftp"} here. -@vindex ange-ftp-gateway-ftp-program-name - -@code{ange-ftp-make-backup-files}: A list of operating systems for which -ange-ftp will make Emacs backup files on the remote host. For example, -@code{'(unix)} makes sense, but @code{'(unix vms)} or @code{'(vms)} -would be silly, since VMS makes its own backups. The host type is -determined by the function @code{ange-ftp-host-type}. Possible host -types are: @code{dumb-unix}; @code{vos}; @code{vms}; @code{mts}; and -@code{unix}. The default of @code{nil} means make no backups on remote -hosts. -@vindex ange-ftp-make-backup-files -@cindex backup files - -@code{ange-ftp-path-format}: This variable dictates the format of a -fully expanded remote pathname. This is a cons @code{(REGEXP . (HOST -USER PATH))}, where @code{REGEXP} is a regular expression matching the -full remote pathname, and @code{HOST}, @code{USER}, and @code{PATH} are -the numbers of parenthesised expressions in @code{REGEXP} for the components -(in that order). The syntax can be customised with this variable to a -certain extent, but there are limitations. The default is @* -@code{'("^/\\(\\([^@@/:]*\\)@@\\)?\\([^@@/:]*\\):\\(.*\\)" . (3 2 4))}. -@vindex ange-ftp-path-format - -@code{ange-ftp-multi-msgs}: A regular expression matching messages from -the ftp process that start a multiline reply. The default is @* -@code{"^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^530-\\|^4[25]1-"} -@vindex ange-ftp-multi-msgs - -@code{ange-ftp-good-msgs}: A regular expression matching messages from -the ftp process that indicate that the action that was initiated has -completed successfully. The default is -@code{"^220 \\|^230 \\|^226\\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark"}. -@vindex ange-ftp-good-msgs - -@code{ange-ftp-skip-msgs}: A regular expression matching messages from -the ftp process that can be ignored. The default is -@example -(concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|" - "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|" - "^local:\\|^Trying\\|^125 \\|^550-") -@end example -@noindent -but you might need to tweak it if ange-ftp is giving up when it -shouldn't. -@vindex ange-ftp-skip-msgs - -@code{ange-ftp-fatal-msgs}: A regular expression matching messages from -the FTP process that indicate something has gone drastically wrong -attempting the action that was initiated and that the FTP process should -(or already has) been killed. The default is -@example -(concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|" - "^No control connection\\|unknown host\\|^lost connection") -@end example -@vindex ange-ftp-fatal-msgs - -@code{ange-ftp-gateway-fatal-msgs}: Regular expression matching messages -from the rlogin / telnet process that indicates that logging in to the -gateway machine has gone wrong. The default is -@example -"No route to host\\|Connection closed\\|No such host\\|Login incorrect" -@end example -@vindex ange-ftp-gateway-fatal-msgs - -@code{ange-ftp-tmp-name-template}: This should be a directory and a -filename prefix indicating where ange-ftp should make temporary files. -The default of @code{"/tmp/ange-ftp"} should be fine for most systems. -@vindex ange-ftp-tmp-name-template -@cindex temporary files - -@code{ange-ftp-retry-time}: Number of seconds to wait before retrying if -a file or listing doesn't arrive. For slow connections, you might get a -``listing unreadable'' error messages -@cindex listing unreadable error -or an empty buffer for a file that you know has something in it. The -solution is to increase the value of @code{ange-ftp-retry-time}. Its default -value is 5 which is plenty for reasonable connections. However, for -some transatlantic connections 20 might be a better value. -@vindex ange-ftp-retry-time - -@node Using ange-ftp, Getting help, Installing ange-ftp, Top -@comment node-name, next, previous, up -@chapter Using ange-ftp - -Once you have ange-ftp installed, you never need worry about using FTP -again. The interface is completely transparent, and you may now use -Emacs commands such as @kbd{C-x C-f} (@code{find-file}) -@pindex find-file -on @emph{any} -file that your local host (or, if you are using one) your gateway can -access. That file may be a regular file (for editing, viewing etc.), a -directory (for invoking Dired) or even a symbolic link -@cindex symbolic links -(pointing to a -directory or a regular file). All it takes is an extended filename -syntax. For example, if you give the filename -@example -/ange@@anorman:/tmp/notes -@end example -@noindent -to @code{find-file}, then ange-ftp will spawn an FTP process, connect to -the host @code{anorman} as user @code{ange}, get the file -@file{/tmp/notes} and pop up a buffer containing the contents of that -file as if it were on the local filesystem. If ange-ftp needed a -password to connect then it would prompt the user in the minibuffer. -From then on you can edit that file as if it were any other file: saving -is with @kbd{C-x C-s} as usual --- in fact, everything is as usual. - -Ange-ftp is also extremely useful for regular "file-transfer" FTP jobs. -Since Dired also works on remote directories when using ange-ftp, you -will be able to browse the filesystem on your favourite archive site -with consummate ease. - -@menu -* Remote filenames:: The ange-ftp extended filename syntax. -* Using Dired:: Browsing directories. -* Using a .netrc:: Preventing password pestering. -* Ange-ftp commands:: Interactive commands supplied by ange-ftp. -* DL support:: For hosts using descriptive directory listings. -* Non-Unix Hosts:: Some hosts have funny filenames. -* Completion:: On filenames and hostnames. -* Accessing the FTP process:: For when manual tinkering is needed. -@end menu - -@node Remote filenames, Using Dired, , Using ange-ftp -@comment node-name, next, previous, up -@section Remote filename syntax - -The general form of the extended filename syntax is -@example -/user@@host:path -@end example -@noindent -which refers to the file pointed to by @code{path} on machine -@code{host} when logging in as user @code{user}. When @code{path} is -supplied as a relative file-name (that is, without a leading @samp{/}) -it is relative to @code{user}'s home directory (although such relative -filenames are ultimately converted to absolute ange-ftp pathnames). You -may even refer to home directories -@cindex home directories of other users -@cindex other users' home directories -of users on remote Unix sites using the -standard tilde @samp{~} notation. -@code{host} needs to be -the fully qualified pathname if the local or gateway machine requires it -to be (however hostname completion is available if it is included in -your @file{.netrc} -- @xref{Using a .netrc}), or it may be an IP -@cindex IP numbers -@cindex numeric Internet addresses -number if your nameserver can't find the site. The @code{user@@} part -may be omitted, in which case the username is chosen on the basis of the -variable @code{ange-ftp-default-user} -@vindex ange-ftp-default-user -(@xref{Other options}) and your -@file{.netrc}. If a password is requested by the FTP process, ange-ftp -will either prompt you for it, or generate one on the basis of the -variables @code{ange-ftp-default-password}, -@vindex ange-ftp-default-password -and your @file{.netrc}. - -Thus the following are all valid ange-ftp filenames: -@example -/anonymous@@waldo.uranium.com:pub/games/wumpus -/root@@127.44.3.1:/etc/passwd -/jbrown@@freddie.ucla.edu:~mblack/ -/alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.Z -@end example - -@node Using Dired, Using a .netrc, Remote filenames, Using ange-ftp -@comment node-name, next, previous, up -@section Using Dired - -This feature of ange-ftp is particularly useful when file-transfers, as -opposed to file-editing, are the order of the day. Simply run -@code{find-file} on a directory to -get a listing of the files in that directory. For example, you might -run @code{find-file} on -@example -/anonymous@@archive.site.com:pub -@end example -@noindent -to see what's in the @file{pub} directory of your favourite archive -@cindex archive sites -site. This brings up a Dired buffer of all the files in that directory. -The @kbd{f} command is useful for looking at @file{README} files --- if -you then decide to save it @kbd{C-x C-w} is useful. You can also use -this method to copy files, but the @kbd{c} command is easier. The -@kbd{f} command can also be used to descend the directory tree by -applying it to directories. - -You can also use Dired to refresh ange-ftp's internal cache. If you -(or anybody else) has changed a remote directory since you first accessed it -with ange-ftp, completion is not provided on any new files that ange-ftp -does not know about. If you have -(or create) a Dired buffer which contains the modified directory, -executing @code{revert-buffer} -@pindex revert-buffer -with a prefix argument (@kbd{C-u g} in the Dired buffer) -will force a refresh of both the buffer @emph{and also ange-ftp's -internal cache}. If you find that filename completion isn't working on a -@cindex filename completion -file that you @emph{know} is there, this is how to fix the problem. - -The version of Dired supplied with Emacs version 18.58 (and earlier -versions) does not include a capability for multiple file transfers. The -@cindex multiple file transfers -@cindex wildcards -Tree Dired package (@xref{Obtaining source code}), however, is ideal -for this application. Tree Dired provides facilities for maintaining an -entire directory tree in a Dired buffer, for marking files which match a -certain regexp (or you can select files interactively) and then copying -all those files to your local host (or even a different remote host). -Another useful feature is Virtual Dired, which allows you to save Dired -@cindex virtual dired -buffers of remote hosts, allowing you to browse them at a later date -without actually needing to connect to the host. See the documentation -for Tree Dired for more details. - -Since ange-ftp is mostly transparent, modifying Dired or Tree Dired by -means of hooks or keybindings should still work. - -@node Using a .netrc, Ange-ftp commands, Using Dired, Using ange-ftp -@comment node-name, next, previous, up -@section Using a .netrc file - -Being prompted for passwords all the time can get rather annoying, but -there is a way to fix the problem --- a @file{.netrc} (but @xref{Other -options} and @code{ange-ftp-netrc-filename} -@vindex ange-ftp-netrc-filename -if you want another -filename) file in your home directory. Basically, this is a file (in the -format of Unix @code{netrc(5)}) which -contains the names of all the machines you regularly login to, as well -as the username and password you use for that machine. You can also -supply an account password, if required. - -Your @file{.netrc} file consists of lines of the form -@example -machine login password -@end example -@noindent -It doesn't all have to be on the one line, though: any @code{login} or -@code{password} commands in the file refer to the previous -@code{machine} command. You can also have @code{account -} commands if you need special account passwords. - -For example, you might have the following line in your @file{.netrc}: -@example -machine Y.local.lan.edu login myname password secret -@end example -@noindent -Then if you run @code{find-file} on the file @file{/Y.local.lan.edu:somefile} -you will automatically be logged in as user @code{myname} with password -@code{secret}. You can still login under another name and password, if -you so desire: just include the @code{user@@} part of the filename. - -You may also include a default option, as follows: -@example -default login password -@end example -@noindent -which applies to any other machines not mentioned elsewhere in your -@file{.netrc}. A particularly useful application of this is with -anonymous logins: -@cindex anonymous FTP -@example -default login myname password myname@@myhost.edu -@end example -@noindent -so that accessing @file{/anyhost:anyfile} will automatically log you in -anonymously, provided the host is not mentioned in the @file{.netrc}. -Note also that if the value of @code{ange-ftp-default-user} is -@vindex ange-ftp-default-user -non-@code{nil}, its value will have precedence over the username -supplied in the default option of the @file{.netrc}. - -The @file{.netrc} file is also useful in another regard: machines -included in it are provided with hostname completion. That is, for any -@cindex hostname completion -machine in the @file{.netrc}, you need only type a slash and the first -few characters of its name and then press @key{TAB} to be logged in -automatically with a username and password from the @file{.netrc} file. -So it's a good idea to put hosts you use regularly in your @file{.netrc} -as well: -@example -machine archive.site.com login anonymous password myname@@X.local.lan.edu -@end example - - -@node Ange-ftp commands, DL support, Using a .netrc, Using ange-ftp -@comment node-name, next, previous, up -@section Ange-ftp commands - -Ange-ftp supplies a few interactive commands to make connecting with -hosts a little easier. - -@noindent -Command @code{ange-ftp-set-user}: Prompts for a hostname and a username. -Next time access to the host is attempted, ange-ftp will attempt to log -in again with the new username. -@pindex ange-ftp-set-user - -@noindent -Command @code{ange-ftp-set-passwd}: Prompts for a hostname, user and -password. Future logins to that host as that user will use the given -password. -@pindex ange-ftp-set-passwd - -@noindent -Command @code{ange-ftp-set-account}: Prompts for a hostname, user and -account. Future logins to that host as that user will use the given -account. -@pindex ange-ftp-set-account - -Note that the effects of the above three commands only last the duration -of the current Emacs session. To make their effects permanent, you may -include them as lisp code in your @file{.emacs}: -@example -(ange-ftp-set-user HOST USER) -(ange-ftp-set-password HOST USER PASSWORD) -(ange-ftp-set-account HOST USER ACCOUNT) -@end example -@noindent -This is an alternative to using a @file{.netrc}; @xref{Using a .netrc}. - -@noindent -Command @code{ange-ftp-kill-ftp-process}: kill the FTP process -associated with a given buffer's filename (by default the current -buffer). This is an easy way to achieve a resynch: any future accesses -to the remote host will cause the FTP process to be recreated. -@pindex ange-ftp-kill-ftp-process - -@node DL support, Non-Unix Hosts, Ange-ftp commands, Using ange-ftp -@comment node-name, next, previous, up -@section Descriptive directory listings - -Some hosts (such as @code{cs.uwp.edu}) now use descriptive directory -listings -@cindex descriptive directory listings -@cindex extended directory listings -(which in fact contain @emph{less} information than the -standard listing!) when issued the @code{ls} command, and ange-ftp has -been modified to cope with this. Ange-ftp can detect such listings, but -if you regularly use a remote host which uses this extended listing -format you should set the variable @code{ange-ftp-dl-dir-regexp} to a -@vindex ange-ftp-dl-dir-regexp -regular expression which matches directories using the extended listing -format. You shouldn't anchor the regexp with @samp{$} -- that way the -regexp will match subdirectories as well. Alternatively, you can use -the interactive command @code{ange-ftp-add-dl-dir} to temporarily add a -@pindex ange-ftp-add-dl-dir -remote directory for this Emacs session only. - -Tree Dired has been modified to work with such descriptive listings. - -@node Non-Unix Hosts, Completion, DL support, Using ange-ftp -@comment node-name, next, previous, up -@section Using ange-ftp with non-Unix hosts - -Ange-ftp also works with some non-Unix hosts, although not necessarily -with all the features available with Unix hosts. VMS, CMS, and MTS -systems will all now work with ange-ftp and Tree Dired (although -Classical Dired may well be broken on such systems.) Filename completion -also now works on these hosts. - -Ange-ftp should be able to automatically detect which type of host you -are using (VMS, CMS or MTS), but if it is unable to do so you can fix -the problem by setting the appropriate -@code{ange-ftp-TYPE-host-regexp} variable (where @code{TYPE} is one of -@samp{vms}, @samp{cms} or @samp{mts}) -- see below. If ange-ftp is unable -to automatically detect any VMS, CMS or MTS host, please report this as -a bug: @xref{Bugs}. - -In all cases the file-name conventions of the remote host are converted -to a UNIX-ish format, and this is the format you should use to find -files on such hosts. - -@menu -* VMS support:: Using ange-ftp with VMS systems -* CMS support:: Using ange-ftp with CMS systems -* MTS support:: Using ange-ftp with MTS systems -@end menu - -@node VMS support, CMS support, , Non-Unix Hosts -@comment node-name, next, previous, up -@subsection VMS support -@cindex VMS filenames -VMS filenames are of the form @code{FILE.TYPE;##}, where both -@code{FILE} and @code{TYPE} can be up to 39 characters long, and -@code{##} is an integer version number between 1 and 32,767. Valid -characters in filenames are @samp{A}-@samp{Z}, @samp{0}-@samp{9}, -@samp{_}, @samp{-} and @samp{$}, however @samp{$} cannot begin a -filename and @samp{-} cannot be used as the first or last character. - -Directories in VMS are converted to the standard UNIX @samp{/} notation. -For example, the VMS filename -@example -PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -@end example -would be entered as -@noindent -@example -/PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -@end example -@noindent -(The double @samp{$} is required to prevent Emacs from attempting to -expand an environment variable.) Similarly, to anonymously FTP the file -@file{[.CSV.POLICY]RULES.MEM;1} from @code{ymir.claremont.edu} you would -type @kbd{C-x C-f -/anonymous@@ymir.claremont.edu:CSV/POLICY/RULES.MEM;1}. You can always -drop off the @samp{;##} part at the end of the filename to get the -latest version. - -Sandy Rutherford provides some tips for using VMS hosts: -@itemize @bullet -@item -Although VMS is not case sensitive, EMACS running under UNIX is. -Therefore, to access a VMS file, you must enter the filename with upper -case letters. - -@item -To access the latest version of file under VMS, you use the filename -without the @samp{;} and version number. You should always edit the -latest version of a file. If you want to edit an earlier version, copy -it to a new file first. This has nothing to do with ange-ftp, but is -simply good VMS operating practice. Therefore, to edit @file{FILE.TXT;3} -(say 3 is latest version), do @kbd{C-x C-f -/ymir.claremont.edu:FILE.TXT}. If you inadvertently do -@example -@kbd{C-x C-f /ymir.claremont.edu:FILE.TXT;3} -@end example -@noindent -you will find that VMS will not allow -you to save the file because it will refuse to overwrite -@file{FILE.TXT;3}, but instead will want to create @file{FILE.TXT;4}, -and attach the buffer to this file. To get out of this situation, -@kbd{M-x write-file /ymir.claremont.edu:FILE.TXT} will attach the buffer -to latest version of the file. For this reason, in Tree Dired @kbd{f} -(@code{dired-find-file}), -@pindex dired-find-file -always loads the file sans version, whereas @kbd{v}, -(@code{dired-view-file}), -@pindex dired-view-file -always loads the explicit version number. The -reasoning being that it reasonable to view old versions of a file, but -not to edit them. - -@item -VMS filenames often contain @samp{$} characters: make sure you always -quote these as @samp{$$} and watch out for the Emacs bug which fails to -quote @samp{$}'s when defaults are presented in the minibuffer: see -@xref{Bugs}. -@end itemize - -Ange-ftp should automatically detect that you are using a VMS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{ange-ftp-add-vms-host} -@pindex ange-ftp-add-vms-host -to inform ange-ftp manually. For a more permanent effect, or -if you use a VMS host regularly, it's a good idea to set -@code{ange-ftp-vms-host-regexp} to a regular expression matching that -@vindex ange-ftp-vms-host-regexp -host's name. For instance, if you use @code{ymir.claremont.edu} a lot, -place the following in your .emacs: -@example -(setq ange-ftp-vms-host-regexp "^ymir.claremont.edu$") -@end example - -@node CMS support, MTS support, VMS support, Non-Unix Hosts -@comment node-name, next, previous, up -@subsection CMS support -Ange-ftp has full support, including Tree Dired support, for hosts -running CMS. - -@cindex CMS filenames -CMS filenames are entered in a UNIX-y way. Minidisks are -treated as UNIX directories; for example to access the file @file{READ.ME} in -minidisk @file{*.311} on @file{cuvmb.cc.columbia.edu}, you would enter -@example -/anonymous@@cuvmb.cc.columbia.edu:/*.311/READ.ME -@end example -If @file{*.301} is the default minidisk for this account, you could access -@file{FOO.BAR} on this minidisk as -@example -/anonymous@@cuvmb.cc.columbia.edu:FOO.BAR -@end example -CMS filenames are of the form @file{FILE.TYPE}, where both @file{FILE} -and @file{TYPE} can be up to 8 characters. Again, beware that CMS -filenames are always upper case, and hence must be entered as such. - -Sandy Rutherford provides some tips on using CMS hosts: -@itemize @bullet -@item -CMS machines, with the exception of anonymous accounts, nearly always -need an account password. To have ange-ftp send an account password, -you can either include it in your @file{.netrc} (@xref{Using a .netrc}), or use -@code{ange-ftp-set-account}. -@pindex ange-ftp-set-account - -@item -Ange-ftp cannot send ``write passwords'' for a minidisk. Hopefully, we -can fix this. -@end itemize - -Ange-ftp should automatically detect that you are using a CMS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{ange-ftp-add-cms-host} -@pindex ange-ftp-add-cms-host -to inform ange-ftp manually. For a more permanent effect, or -if you use a CMS host regularly, it's a good idea to set -@code{ange-ftp-cms-host-regexp} to a regular expression matching that -@vindex ange-ftp-cms-host-regexp -host's name. - -@node MTS support, , CMS support, Non-Unix Hosts -@comment node-name, next, previous, up -@subsection MTS support -Ange-ftp has full support, including Tree Dired support, for hosts -running the Michigan terminal system, and should be able to -automatically recognise any MTS machine. - -@cindex MTS filenames -MTS filenames are entered in a UNIX-y way. For example, if your account -was @file{YYYY}, the file @file{FILE} in the account @file{XXXX:} on -@file{mtsg.ubc.ca} would be entered as -@example -/YYYY@@mtsg.ubc.ca:/XXXX:/FILE -@end example -In other words, MTS accounts are treated as UNIX directories. Of course, -to access a file in another account, you must have access permission for -it. If @file{FILE} were in your own account, then you could enter it in a -relative path fashion as -@example -/YYYY@@mtsg.ubc.ca:FILE -@end example -MTS filenames can be up to 12 characters. Like UNIX, the structure of the -filename does not contain a type (i.e. it can have as many @samp{.}'s as you -like.) MTS filenames are always in upper case, and hence be sure to enter -them as such! MTS is not case sensitive, but an EMACS running under UNIX -is. - -Ange-ftp should automatically detect that you are using an MTS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{ange-ftp-add-mts-host} -@pindex ange-ftp-add-mts-host -to inform ange-ftp manually. For a more permanent effect, or -if you use an MTS host regularly, it's a good idea to set -@code{ange-ftp-mts-host-regexp} to a regular expression matching that -@vindex ange-ftp-mts-host-regexp -host's name. - -@node Completion, Accessing the FTP process, Non-Unix Hosts, Using ange-ftp -@comment node-name, next, previous, up -@section File- and host-name completion - -Full filename completion is supported on all remote UNIX hosts and some -non-Unix hosts. Hostnames also have completion if they are mentioned in -the @file{.netrc} and no username is specified. However using the -filename completion feature can be a bit of a two edged sword. - -To understand why, we need to discuss how ange-ftp works. Whenever -ange-ftp is asked to find a remote file (or directory) an @code{ls} -command is sent to the FTP process to list all the files in the -directory. This list is maintained in an internal cache, to provide -filename completion for later requests on that directory. Ange-ftp keeps -this cache up-to-date by monitoring Emacs commands which affect files -and directories, but if a process outside Emacs (such as another user) -changes a directory (e.g. a new file is added) -completion won't work on -that file since ange-ftp doesn't know about it yet. The solution if to -force ange-ftp to reread the directory and update it's cache, and the -easiest way to do that is with Dired --- @xref{Using Dired} to see how. - -Another problem is that the @code{ls} command can take a long time, -especially when dealing with distant hosts over slow links. So if you're -after a file in the @file{pub/images} directory but nothing else, it's a -better idea to type @kbd{pub/images/file @key{TAB}} than @kbd{pub/im @key{TAB}} -which will force a read of the @file{pub} directory (since -ange-ftp needs to know how to complete @code{im}). A little extra typing -can often save a lot of waiting. Don't be afraid to use the @key{TAB} -key once the directory is cached, though. - -@node Accessing the FTP process, , Completion, Using ange-ftp -@comment node-name, next, previous, up -@section Accessing the FTP process buffer - -The FTP process used to access the remote files is available for access -if you wish. It will be in a buffer -@cindex process buffers -@cindex buffers -called @samp{"*ftp @var{remote-file-name}*"}, -i.e. if you found the file -@example -/anonymous@@archive.site.com:pub/README -@end example -@noindent -there will be a buffer -@example -*ftp anonymous@@archive.site.com* -@end example -@noindent -where all the transfers are taking place. You can have a look at the buffer -using @kbd{C-x b} as usual, and even type in commands to the FTP process -under an interface very much like @samp{shell-mode}. There are two -instances when doing this can be very useful: one is accessing non-UNIX -hosts, where Dired and filename completion may not work (if ange-ftp -even works at all). The other is multiple (i.e. wildcard) file transfers -@cindex multiple file transfers -@cindex wildcards -which the standard version of Dired does not handle (but Tree Dired -@emph{does}, and is worth installing for this feature alone.) If you -are going to use @code{mget} or @code{mput}, make sure you type -@code{glob} first: ange-ftp turns globbing off by default. Don't be -afraid of changing directories, either --- ange-ftp always uses absolute -pathnames when communicating with the FTP process. - -You can kill the FTP process at any time simply by killing this buffer. -@cindex FTP processes -@cindex processes -This won't cause ange-ftp any grief whatsoever --- if you later make -another request to that host, ange-ftp will simply fire up another -process and create a new buffer to hold it. - -@node Getting help, Bugs, Using ange-ftp, Top -@comment node-name, next, previous, up -@chapter Getting help - -Ange-ftp has its own mailing list modestly called ange-ftp-lovers where -ange-ftp users discuss new features, problems, bug fixes etc. There is -also another list called ange-ftp-lovers-announce which is reserved -exclusively for the announcement of new versions. All -users of ange-ftp are welcome to subscribe (see below) to either of -these lists. New versions of ange-ftp are posted periodically to -these lists. - -To [un]subscribe to ange-ftp-lovers or ange-ftp-lovers-announce, or to -report mailer problems with the list, please mail one of the following -addresses: -@example -ange-ftp-lovers-request@@anorman.hpl.hp.com -ange-ftp-lovers-request%anorman.hpl.hp.com@@hplb.hpl.hp.com -hplb.hpl.hp.com!anorman.hpl.hp.com!ange-ftp-lovers-request -hplabs.hpl.hp.com!anorman.hpl.hp.com!ange-ftp-lovers-request -@end example -@noindent -Please don't forget the @samp{-request} part, and please make it clear -in the request which mailing list you wish to join. - -For mail to be posted directly to ange-ftp-lovers, send to one of the -following addresses: -@example -ange-ftp-lovers@@anorman.hpl.hp.com -ange-ftp-lovers%anorman.hpl.hp.com@@hplb.hpl.hp.com -hplb.hpl.hp.com!anorman.hpl.hp.com!ange-ftp-lovers -hplabs.hpl.hp.com!anorman.hpl.hp.com!ange-ftp-lovers -@end example -@noindent -The ange-ftp-lovers mailing list is archived on -@example -ftp.reed.edu:pub/mailing-lists/ange-ftp/ -@end example - -The newsgroup @code{gnu.emacs.help} also occasionally discusses ange-ftp. - -@node Bugs, Concept Index, Getting help, Top -@comment node-name, next, previous, up -@chapter Bugs and Wish List - -Here is a list of the known bugs in ange-ftp: - -@itemize @bullet -@item -Be warned that files created by using ange-ftp will take account of the -umask -@cindex umask -of the ftp daemon process rather than the umask of the creating -user. This is particulary important when logging in as the root user. -The way that I tighten up the ftp daemon's umask under HP-UX is to make -sure that the umask is changed to 027 before I spawn @file{/etc/inetd}. I -suspect that there is something similar on other systems. - -@item -Some combinations of FTP clients and servers break and get out of sync -when asked to list a non-existent directory. Some of the -@code{ai.mit.edu} machines cause this problem for some FTP clients. - -@item -Ange-ftp does not check to make sure that when creating a new file, -you provide a valid filename for the remote operating system. -If you do not, then the remote FTP server will most likely -translate your filename in some way. This may cause ange-ftp to -get confused about what exactly is the name of the file. The -most common causes of this are using lower case filenames on systems -which support only upper case, and using filenames which are too -long. - -@item -Null (blank) passwords confuse both ange-ftp and some FTP daemons. - -@item -ange-ftp likes to use pty's -@cindex pty -to talk to its FTP processes. If GNU Emacs -creates a FTP process that only talks via pipes (for example, if -@code{process-connection-type} is @code{nil}) -@vindex process-connection-type -then ange-ftp won't be getting the information it requires at the time that -it wants it since pipes flush at different times to pty's. One -disgusting way around this problem is to talk to the FTP process via -rlogin which does the `right' things with pty's. - -@item -You need to quote @samp{$} characters in filenames by using @samp{$$} -instead. This isn't actually a bug, but rather an Emacs convention -(which allows environment variables in filenames.) What @emph{is} an bug -is that when filenames containing @samp{$}'s are inserted in the -minibuffer as defaults, the @samp{$} is not converted into the @samp{$$} -quoted form --- hopefully this will be fixed in version 19. It doesn't -usually bother Unix users, but VMS filenames often contain @samp{$}. -Incidentally, Sebastian Kremer's @code{gmhist} package -@pindex gmhist -(which comes with the Tree Dired distribution: @xref{Obtaining source code}) -fixes this bug. - -@item -@cindex symbolic links -Some hosts (notably ULTRIX) -@cindex ULTRIX -mark symbolic links with a @samp{@@} character in an @code{ls -F} -listing. The variable @code{dired-ls-F-marks-symlinks} -@vindex dired-ls-F-marks-symlinks -when set to @code{t} (the default) alerts Dired to this behaviour and -everything is OK. Enabling this behaviour by default is not generally a -problem on hosts which does @emph{not} mark symlinks in this way, but if -you have @code{dired-ls-F-marks-symlinks} set to @code{t} while -accessing a such a host, then Dired will think that a symbolic link whose name -ends in @samp{@@} (a strange thing indeed!) is a regular file. The fix -(other than setting @code{dired-ls-F-marks-symlinks to} @code{nil}, a bad idea -if you regularly access hosts who mark symbolic links) is to remove -@samp{F} from the @code{ls} listing switches (use @kbd{C-u s} in the -Dired buffer.) - -Another problem with symbolic links arises with hosts who do not show -the linked file with @samp{->} in the listing, meaning that Dired will -not recognize the symlink. The solution here is to get a decent -@code{ls} program on that machine. - -@item -No classic dired support for non-UNIX systems. Tree dired was enough. - -@item -If a directory listing is attempted for an empty directory on (at least some) -VMS hosts, an ftp error is given. This is really an ftp bug, and I don't -know how to get ange-ftp work to around it. - -@item -Bombs on filenames that start with a space. Deals well with filenames -containing spaces, but beware that the remote ftpd may not like them much. - -@item -@cindex auto-saving -Doesn't autosave. Maybe someone could implement auto-saving on the local -host ... - -@item -@cindex compressing files -The code to do compression of files over ftp is not as careful as it -should be. It deletes the old remote version of the file, before -actually checking if the local to remote transfer of the compressed file -succeeds. Of course to delete the original version of the file after -transferring the compressed version back is also dangerous, because some -OS's have severe restrictions on the length of filenames, and when the -compressed version is copied back the @file{-Z} or @file{.Z} may be -truncated. Then, ange-ftp would delete the only remaining version of the -file. Maybe ange-ftp should make backups when it compresses files? - -@item -@cindex copying -Remote to remote copying of files on non-Unix machines can be risky. Depending -on the variable @code{ange-ftp-binary-file-name-regexp}, ange-ftp will use binary -mode for the copy. Between systems of different architecture, this still -may not be enough to guarantee the integrity of binary files. Binary file -transfers from VMS machines are particularly problematical. - -@item -@cindex CMS minidisks -Some CMS machines do not assign a default minidisk when you ftp them as -anonymous. It is then necessary to guess a valid minidisk name, and -@code{cd} to it. This is (understandably) beyond ange-ftp; however -Sebastian Kremer says: -@quotation -It is beyond ange-ftp, but if the @code{init} ftp macro were supported, one -could write the appropriate @code{cd} command into that. I used to do that -on a CMS machine I had an account on because I never could remember -the name of the minidisk. I think I even had to give an @code{account} -command, too. Supporting @code{init} would be a very handy thing. - -Hmm, why start @code{ftp(1)} with the @code{-n} flag at all? -@end quotation - -@item -For CMS support, we send too many @code{cd}'s. Since @code{cd}'s are -cheap, I haven't worried about this too much. Eventually, we should have -some caching of the current minidisk. -@end itemize - -If you find any bugs or problems with this package, @strong{please} -e-mail the author. Ideas and constructive comments are especially -welcome. So are any enhancements to ange-ftp, preferably debugged and -documented. Also welcome are any typo fixes, corrections or additions to -this manual. And just so you don't forget, here's Ange's address again: -@example -ange@@hplb.hpl.hp.com -@end example -@noindent -Enjoy! - -@node Concept Index, Variable and command index, Bugs, Top -@comment node-name, next, previous, up -@unnumbered Concept Index - -@printindex cp - -@node Variable and command index, , Concept Index, Top -@unnumbered Variable and command index - -@printindex vr - -@contents - -@bye - diff -r 498bf5da1c90 -r 0d2f883870bc man/custom.texi --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/man/custom.texi Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,665 @@ +\input texinfo.tex + +@c %**start of header +@setfilename custom +@settitle The Customization Library +@iftex +@afourpaper +@headings double +@end iftex +@c %**end of header + +@node Top, Introduction, (dir), (dir) +@comment node-name, next, previous, up +@top The Customization Library + +Version: 1.40 + +@menu +* Introduction:: +* User Commands:: +* The Customization Buffer:: +* Declarations:: +* Utilities:: +* The Init File:: +* Wishlist:: +@end menu + +@node Introduction, User Commands, Top, Top +@comment node-name, next, previous, up +@section Introduction + +This library allows customization of @dfn{user options}. Currently two +types of user options are supported, namely @dfn{variables} and +@dfn{faces}. Each user option can have four different values +simultaneously: +@table @dfn +@item factory setting +The value specified by the programmer. +@item saved value +The value saved by the user as the default for this variable. This +overwrites the factory setting when starting a new emacs. +@item current value +The value used by Emacs. This will not be remembered next time you +run Emacs. +@item widget value +The value entered by the user in a customization buffer, but not yet +applied. +@end table + +Variables also have a @dfn{type}, which specifies what kind of values +the variable can hold, and how the value is presented in a customization +buffer. By default a variable can hold any valid expression, but the +programmer can specify a more limited type when declaring the variable. + +The user options are organized in a number of @dfn{groups}. Each group +can contain a number user options, as well as other groups. The groups +allows the user to concentrate on a specific part of emacs. + +@node User Commands, The Customization Buffer, Introduction, Top +@comment node-name, next, previous, up +@section User Commands + +The following commands will create a customization buffer: + +@table @code +@item customize +Create a customization buffer containing a specific group, by default +the @code{emacs} group. + +@item customize-variable +Create a customization buffer containing a single variable. + +@item customize-face +Create a customization buffer containing a single face. + +@item customize-apropos +Create a customization buffer containing all variables, faces, and +groups that match a user specified regular expression. +@end table + +@node The Customization Buffer, Declarations, User Commands, Top +@comment node-name, next, previous, up +@section The Customization Buffer. + +The customization buffer allows the user to make temporary or permanent +changes to how specific aspects of emacs works, by setting and editing +user options. + +The customization buffer contains three types of text: + +@table @dfn +@item informative text +where the normal editing commands are disabled. + +@item editable fields +where you can edit with the usual emacs commands. Editable fields are +usually displayed with a grey background if your terminal supports +colors, or an italic font otherwise. + +@item buttons +which can be activated by either pressing the @kbd{@key{ret}} while +point is located on the text, or pushing @kbd{mouse-2} while the mouse +pointer is above the tex. Buttons are usually displayed in a bold +font. +@end table + +You can move to the next the next editable field or button by pressing +@kbd{@key{tab}} or the previous with @kbd{M-@key{tab}}. Some buttons +have a small helpful message about their purpose, which will be +displayed when you move to it with the @key{tab} key. + +The buffer is divided into three part, an introductory text, a list of +customization options, and a line of customization buttons. Each part +will be described in the following. + +@menu +* The Introductory Text:: +* The Customization Options:: +* The Variable Options:: +* The Face Options:: +* The Group Options:: +* The State Button:: +* The Customization Buttons:: +@end menu + +@node The Introductory Text, The Customization Options, The Customization Buffer, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Introductory Text + +The start of the buffer contains a short explanation of what it is, and +how to get help. It will typically look like this: + +@example +This is a customization buffer. +Push RET or click mouse-2 on the word _help_ for more information. +@end example + +Rather boring. It is mostly just informative text, but the word +@samp{help} is a button that will bring up this document when +activated. + +@node The Customization Options, The Variable Options, The Introductory Text, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Customization Options + +Each customization option looks similar to the following text: + +@example + *** custom-background-mode: default + State: this item is unchanged from its factory setting. + [ ] [?] The brightness of the background. +@end example + +The option contains the parts described below. + +@table @samp +@item *** +The Level Button. The customization options in the buffer are organized +in a hierarchy, which is indicated by the number of stars in the level +button. The top level options will be shown as @samp{*}. When they are +expanded, the suboptions will be shown as @samp{**}. The example option +is thus a subsuboption. + +Activating the level buttons will toggle between hiding and exposing the +content of that option. The content can either be the value of the +option, as in this example, or a list of suboptions. + +@item custom-background-mode +This is the tag of the the option. The tag is a name of a variable, a +face, or customization group. Activating the tag has an effect that +depends on the exact type of the option. In this particular case, +activating the tag will bring up a menu that will allow you to choose +from the three possible values of the `custom-background-mode' +variable. + +@item default +After the tag, the options value is shown. Depending on its type, you +may be able to edit the value directly. If an option should contain a +file name, it is displayed in an editable field, i.e. you can edit it +using the standard emacs editing commands. + +@item State: this item is unchanged from its factory setting. +The state line. This line will explain the state of the option, +e.g. whether it is currently hidden, or whether it has been modified or +not. Activating the button will allow you to change the state, e.g. set +or reset the changes you have made. This is explained in detail in the +following sections. + +@item [ ] +The magic button. This is an abbreviated version of the state line. + +@item [?] +The documentation button. If the documentation is more than one line, +this button will be present. Activating the button will toggle whether +the complete documentation is shown, or only the first line. + +@item The brightness of the background. +This is a documentation string explaining the purpose of this particular +customization option. + +@end table + +@node The Variable Options, The Face Options, The Customization Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Variable Options + +The most common customization options are emacs lisp variables. The +actual editing of these variables depend on what type values the +variable is expected to contain. For example, a lisp variable whose +value should be a string will typically be represented with an editable +text field in the buffer, where you can change the string directly. If +the value is a list, each item in the list will be presented in the +buffer buffer on a separate line, with buttons to insert new items in +the list, or delete existing items from the list. You may want to see +@ref{User Interface,,, widget, The Widget Library}, where some examples +of editing are discussed. + +You can either choose to edit the value directly, or edit the lisp +value for that variable. The lisp value is a lisp expression that +will be evaluated when you start emacs. The result of the evaluation +will be used as the initial value for that variable. Editing the +lisp value is for experts only, but if the current value of the +variable is of a wrong type (i.e. a symbol where a string is expected), +the `edit lisp' mode will always be selected. + +You can see what mode is currently selected by looking at the state +button. If it uses parenthesises (like @samp{( )}) it is in edit lisp +mode, with square brackets (like @samp{[ ]}) it is normal edit mode. +You can switch mode by activating the state button, and select either +@samp{Edit} or @samp{Edit lisp} from the menu. + +You can change the state of the variable with the other menu items: + +@table @samp +@item Set +When you have made your modifications in the buffer, you need to +activate this item to make the modifications take effect. The +modifications will be forgotten next time you run emacs. + +@item Save +Unless you activate this item instead! This will mark the modification +as permanent, i.e. the changes will be remembered in the next emacs +session. + +@item Reset +If you have made some modifications and not yet applied them, you can +undo the modification by activating this item. + +@item Reset to Saved +Activating this item will reset the value of the variable to the last +value you marked as permanent with `Save'. + +@item Reset to Factory Settings +Activating this item will undo all modifications you have made, and +reset the value to the initial value specified by the program itself. +@end table + +By default, the value of large or complicated variables are hidden. You +can show the value by clicking on the level button. + +@node The Face Options, The Group Options, The Variable Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Face Options + +A face is an object that controls the appearance of some buffer text. +The face has a number of possible attributes, such as boldness, +foreground color, and more. For each attribute you can specify whether +this attribute is controlled by the face, and if so, what the value is. +For example, if the attribute bold is not controlled by a face, using +that face on some buffer text will not affect its boldness. If the bold +attribute is controlled by the face, it can be turned either on or of. + +It is possible to specify that a face should have different attributes +on different device types. For example, a face may make text red on a +color device, and bold on a monochrome device. + +The way this is presented in the customization buffer is to have a list +of display specifications, and for each display specification a list of +face attributes. For each face attribute, there is a checkbox +specifying whether this attribute has effect and what the value is. +Here is an example: + +@example + *** custom-invalid-face: (sample) + [ ] Face used when the customize item is invalid. + [INS] [DEL] Display: [ ] Type: [ ] X [ ] TTY + [X] Class: [X] Color [ ] Grayscale [ ] Monochrome + [ ] Background: [ ] Light [ ] Dark + Attributes: [ ] Bold: off + [ ] Italic: off + [ ] Underline: off + [X] Foreground: yellow (sample) + [X] Background: red (sample) + [ ] Stipple: + [INS] [DEL] Display: all + Attributes: [X] Bold: on + [X] Italic: on + [X] Underline: on + [ ] Foreground: default (sample) + [ ] Background: default (sample) + [ ] Stipple: + [INS] +@end example + +This has two display specifications. The first will match all color +displays, independently on whether the device is X11 or a tty, and +whether background color is dark or light. For devices matching this +specification, @samp{custom-invalid-face} will force text to be +displayed in yellow on red, but leave all other attributes alone. + +The second display will simply match everything. Since the list is +prioritised, this means that it will match all non-color displays. For +these, the face will not affect the foreground or background color, but +force the font to be both bold, italic, and underline. + +You can add or delete display specifications by activating the +@samp{[INS]} and @samp{[DEL]} buttons, and modify them by clicking on +the check boxes. The first checkbox in each line in the display +specification is special. It specify whether this particular property +will even be relevant. By not checking the box in the first display, we +match all device types, also device types other than X11 and tty, for +example ms-windows, nextstep, and mac os. + +After modifying the face, you can activate the state button to make the +changes take effect. The menu items in the state button menu is similar +to the state menu items for variables described in the previous section. + +@node The Group Options, The State Button, The Face Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Group Options + +Since Emacs has approximately a zillion configuration options, they have +been organized in groups. Each group can contain other groups, thus +creating a customization hierarchy. The nesting of the customization +within the visible part of this hierarchy is indicated by the number of +stars in the level button. + +Since there is really no customization needed for the group itself, the +menu items in the groups state button will affect all modified group +members recursively. Thus, if you activate the @samp{Set} menu item, +all variables and faces that have been modified and belong to that group +will be applied. For those members that themselves are groups, it will +work as if you had activated the @samp{Set} menu item on them as well. + +@node The State Button, The Customization Buttons, The Group Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The State Line and The Magic Button + +The state line has two purposes. The first is to hold the state menu, +as described in the previous sections. The second is to indicate the +state of each customization item. + +For the magic button, this is done by the character inside the brackets. +The following states have been defined, the first that applies to the +current item will be used: + +@table @samp +@item - +The option is currently hidden. For group options that means the +members are not shown, for variables and faces that the value is not +shown. You cannot perform any of the state change operations on a +hidden customization option. + +@item * +The value if this option has been modified in the buffer, but not yet +applied. + +@item + +The item has has been set by the user. + +@item : +The current value of this option is different from the saved value. + +@item ! +The saved value of this option is different from the factory setting. + +@item @@ +The factory setting of this option is not known. This occurs when you +try to customize variables or faces that have not been explicitly +declared as customizable. + +@item SPC +The factory setting is still in effect. + +@end table + +For non-hidden group options, the state shown is the most severe state +of its members, where more severe means that it appears earlier in the +list above (except hidden members, which are ignored). + +@node The Customization Buttons, , The State Button, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Customization Buttons + +The last part of the customization buffer looks like this: + +@example +[Set] [Save] [Reset] +@end example + +Activating the @samp{[Set]}, @samp{[Save]}, or @samp{[Reset]} +button will affect all modified customization items that are visible in +the buffer. + +@node Declarations, Utilities, The Customization Buffer, Top +@comment node-name, next, previous, up +@section Declarations + +@menu +* Declaring Groups:: +* Declaring Variables:: +* Declaring Faces:: +@end menu + +All the customization declarations can be changes by keyword arguments. +Groups, variables, and faces all share these common keywords: + +@table @code +@item :group +@var{value} should be a customization group. +Add @var{symbol} to that group. +@item :link +@var{value} should be a widget type. +Add @var{value} to the extrenal links for this customization option. +Useful widget types include @code{custom-manual}, @code{info-link}, and +@code{url-link}. +@item :load +Add @var{value} to the files that should be loaded nefore displaying +this customization option. The value should be iether a string, which +should be a string which will be loaded with @code{load-library} unless +present in @code{load-history}, or a symbol which will be loaded with +@code{require}. +@item :tag +@var{Value} should be a short string used for identifying the option in +customization menus and buffers. By default the tag will be +automatically created from the options name. +@end table + +@node Declaring Groups, Declaring Variables, Declarations, Declarations +@comment node-name, next, previous, up +@subsection Declaring Groups + +Use @code{defgroup} to declare new customization groups. + +@defun defgroup symbol members doc [keyword value]... +Declare @var{symbol} as a customization group containing @var{members}. +@var{symbol} does not need to be quoted. + +@var{doc} is the group documentation. + +@var{members} should be an alist of the form ((@var{name} +@var{widget})...) where @var{name} is a symbol and @var{widget} is a +widget for editing that symbol. Useful widgets are +@code{custom-variable} for editing variables, @code{custom-face} for +editing faces, and @code{custom-group} for editing groups.@refill + +Internally, custom uses the symbol property @code{custom-group} to keep +track of the group members, and @code{group-documentation} for the +documentation string. + +The following additional @var{keyword}'s are defined: + +@table @code +@item :prefix +@var{value} should be a string. If the string is a prefix for the name +of a member of the group, that prefix will be ignored when creating a +tag for that member. +@end table +@end defun + +@node Declaring Variables, Declaring Faces, Declaring Groups, Declarations +@comment node-name, next, previous, up +@subsection Declaring Variables + +Use @code{defcustom} to declare user editable variables. + +@defun defcustom symbol value doc [keyword value]... +Declare @var{symbol} as a customizable variable that defaults to @var{value}. +Neither @var{symbol} nor @var{value} needs to be quoted. +If @var{symbol} is not already bound, initialize it to @var{value}. + +@var{doc} is the variable documentation. + +The following additional @var{keyword}'s are defined: + +@table @code +@item :type +@var{value} should be a widget type. +@item :options +@var{value} should be a list of possible members of the specified type. +For hooks, this is a list of function names. +@end table + +@xref{Sexp Types,,,widget,The Widget Library}, for information about +widgets to use together with the @code{:type} keyword. +@end defun + +Internally, custom uses the symbol property @code{custom-type} to keep +track of the variables type, @code{factory-value} for the program +specified default value, @code{saved-value} for a value saved by the +user, and @code{variable-documentation} for the documentation string. + +Use @code{custom-add-option} to specify that a specific function is +useful as an meber of a hook. + +@defun custom-add-option symbol option +To the variable @var{symbol} add @var{option}. + +If @var{symbol} is a hook variable, @var{option} should be a hook +member. For other types variables, the effect is undefined." +@end defun + +@node Declaring Faces, , Declaring Variables, Declarations +@comment node-name, next, previous, up +@subsection Declaring Faces + +Faces are declared with @code{defface}. + +@defun defface face spec doc [keyword value]... + +Declare @var{face} as a customizable face that defaults to @var{spec}. +@var{face} does not need to be quoted. + +If @var{face} has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to @var{spec}. + +@var{doc} is the face documentation. + +@var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}. + +@var{atts} is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, @var{atts} can be a face in which case the attributes of +that face is used. + +The @var{atts} of the first entry in @var{spec} where the @var{display} +matches the frame should take effect in that frame. @var{display} can +either be the symbol `t', which will match all frames, or an alist of +the form @samp{((@var{req} @var{item}...)...)}@refill + +For the @var{display} to match a FRAME, the @var{req} property of the +frame must match one of the @var{item}. The following @var{req} are +defined:@refill + +@table @code +@item type +(the value of (window-system))@br +Should be one of @code{x} or @code{tty}. + +@item class +(the frame's color support)@br +Should be one of @code{color}, @code{grayscale}, or @code{mono}. + +@item background +(what color is used for the background text)@br +Should be one of @code{light} or @code{dark}. +@end table + +Internally, custom uses the symbol property @code{factory-face} for the +program specified default face properties, @code{saved-face} for +properties saved by the user, and @code{face-documentation} for the +documentation string.@refill + +@end defun + +@node Utilities, The Init File, Declarations, Top +@comment node-name, next, previous, up +@section Utilities + +These utilities can come in handy when adding customization support. + +@deffn Widget custom-manual +Widget type for specifying the info manual entry for a customization +option. It takes one argument, an info address. +@end deffn + +@defun custom-add-to-group group member widget +To existing @var{group} add a new @var{member} of type @var{widget}, +If there already is an entry for that member, overwrite it. +@end defun + +@defun custom-add-link symbol widget +To the custom option @var{symbol} add the link @var{widget}. +@end defun + +@defun custom-add-load symbol load +To the custom option @var{symbol} add the dependency @var{load}. +@var{load} should be either a library file name, or a feature name. +@end defun + +@defun custom-menu-create symbol &optional name +Create menu for customization group @var{symbol}. +If optional @var{name} is given, use that as the name of the menu. +Otherwise make up a name from @var{symbol}. +The menu is in a format applicable to @code{easy-menu-define}. +@end defun + +@node The Init File, Wishlist, Utilities, Top +@comment node-name, next, previous, up +@section The Init File + +When you save the customizations, call to @code{custom-set-variables}, +@code{custom-set-faces} are inserted into the file specified by +@code{custom-file}. By default @code{custom-file} is your @file{.emacs} +file. The two functions will initialize variables and faces as you have +specified. + +@node Wishlist, , The Init File, Top +@comment node-name, next, previous, up +@section Wishlist + +@itemize @bullet +@item +The menu items should be grayed out when the information is +missing. I.e. if a variable doesn't have a factory setting, the user +should not be allowed to select the @samp{Factory} menu item. + +@item +We need @strong{much} better support for keyboard operations in the +customize buffer. + +@item +Support real specifiers under XEmacs. + +@item +Integrate with @file{w3} so you can customization buffers with much +better formatting. I'm thinking about adding a name +tag. + +@item +Add an `examples' section, with explained examples of custom type +definitions. + +@item +Support undo using lmi's @file{gnus-undo.el}. + +@item +Make it possible to append to `choice', `radio', and `set' options. + +@item +There should be a way to exit the buffer. + +An @sc{open look} pushpin would do wonders. + +@item +Ask whether set or modified variables should be saved in +@code{kill-buffer-hook}. + +Ditto for @code{kill-emacs-query-functions}. + +@item +Command to check if there are any customization options that +does not belong to an existing group. + +@item +Optionally disable the point-cursor and instead highlight the selected +item in XEmacs. This is like the *Completions* buffer in XEmacs. +Suggested by Jens Lautenbacher +@samp{}.@refill + +@end itemize + +@contents +@bye diff -r 498bf5da1c90 -r 0d2f883870bc man/dired-ref.tex --- a/man/dired-ref.tex Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,477 +0,0 @@ -% Document Type: TeX -% Master File: dired-ref.tex -% TREE DIRED Reference Card for GNU Emacs version 18 on Unix systems -%**start of header -\newcount\columnsperpage - -% This file can be printed with 1, 2, or 3 columns per page (see below). -% Specify how many you want here. Nothing else needs to be changed. - -\columnsperpage=1 - -% Copyright (c) 1991 Free Software Foundation, Inc. - -% This file is part of GNU Emacs. - -% This file is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY. No author or distributor -% accepts responsibility to anyone for the consequences of using it -% or for whether it serves any particular purpose or describes -% any piece of software unless they say so in writing. Refer to the -% GNU Emacs General Public License for full details. -% -% Permission is granted to copy, modify and redistribute this source -% file provided the copyright notice and permission notices are -% preserved on all copies. -% -% Permission is granted to process this file through TeX and print the -% results, provided the printed document carries copyright and -% permission notices identical to the ones below. - -% This file is intended to be processed by plain TeX (TeX82). -% -% The final reference card has six columns, three on each side. -% This file can be used to produce it in any of three ways: -% 1 column per page -% produces six separate pages, each of which needs to be reduced to 80%. -% This gives the best resolution. -% 2 columns per page -% produces three already-reduced pages. -% You will still need to cut and paste. -% 3 columns per page -% produces two pages which must be printed sideways to make a -% ready-to-use 8.5 x 11 inch reference card. -% For this you need a dvi device driver that can print sideways. -% Which mode to use is controlled by setting \columnsperpage above. -% -% TeX Layout commands taken from the GNU Emacs Refcard (thanks to -% Stephen Gildea for this work) - -\def\diredx{$^\dagger$} % marks extra feature not present in dired.el -\let\diredx\diredx % `compile' while ^ still active -\overfullrule0pt -\def\~{\char`~} % an ASCII tilde character - -\def\versionnumber{1.0} -\def\year{1992} -\def\version{\year\ v\versionnumber} - -\def\shortcopyrightnotice{\vskip 1ex plus 2 fill - \centerline{\small \copyright\ \year\ Free Software Foundation, Inc. - Permissions on back. v\versionnumber}} - -\def\copyrightnotice{ -\vskip 1ex plus 2 fill\begingroup\small -\centerline{Copyright \copyright\ \year\ Free Software Foundation, Inc.} -% \centerline{designed by Stephen Gildea, \version} -\centerline{\version} -\centerline{for GNU Emacs version 18 on Unix systems} - -Permission is granted to make and distribute copies of -this card provided the copyright notice and this permission notice -are preserved on all copies. - -For copies of the GNU Emacs manual, write to the Free Software -Foundation, Inc., 675 Massachusetts Ave, Cambridge MA 02139. - -\endgroup} - -% make \bye not \outer so that the \def\bye in the \else clause below -% can be scanned without complaint. -\def\bye{\par\vfill\supereject\end} - -\newdimen\intercolumnskip -\newbox\columna -\newbox\columnb - -\def\ncolumns{\the\columnsperpage} - -\message{[\ncolumns\space - column\if 1\ncolumns\else s\fi\space per page]} - -\def\scaledmag#1{ scaled \magstep #1} - -% This multi-way format was designed by Stephen Gildea -% October 1986. -\if 1\ncolumns - \hsize 4in - \vsize 10in - \voffset -.7in - \font\titlefont=\fontname\tenbf \scaledmag3 - \font\headingfont=\fontname\tenbf \scaledmag2 - \font\smallfont=\fontname\sevenrm - \font\smallsy=\fontname\sevensy - - \footline{\hss\folio} - \def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}} -\else - \hsize 3.2in - \vsize 7.95in - \hoffset -.75in - \voffset -.745in - \font\titlefont=cmbx10 \scaledmag2 - \font\headingfont=cmbx10 \scaledmag1 - \font\smallfont=cmr6 - \font\smallsy=cmsy6 - \font\eightrm=cmr8 - \font\eightbf=cmbx8 - \font\eightit=cmti8 - \font\eighttt=cmtt8 - \font\eightsy=cmsy8 - \textfont0=\eightrm - \textfont2=\eightsy - \def\rm{\eightrm} - \def\bf{\eightbf} - \def\it{\eightit} - \def\tt{\eighttt} - \normalbaselineskip=.8\normalbaselineskip - \normallineskip=.8\normallineskip - \normallineskiplimit=.8\normallineskiplimit - \normalbaselines\rm %make definitions take effect - - \if 2\ncolumns - \let\maxcolumn=b - \footline{\hss\rm\folio\hss} - \def\makefootline{\vskip 2in \hsize=6.86in\line{\the\footline}} - \else \if 3\ncolumns - \let\maxcolumn=c - \nopagenumbers - \else - \errhelp{You must set \columnsperpage equal to 1, 2, or 3.} - \errmessage{Illegal number of columns per page} - \fi\fi - - \intercolumnskip=.46in - \def\abc{a} - \output={% - % This next line is useful when designing the layout. - %\immediate\write16{Column \folio\abc\space starts with \firstmark} - \if \maxcolumn\abc \multicolumnformat \global\def\abc{a} - \else\if a\abc - \global\setbox\columna\columnbox \global\def\abc{b} - %% in case we never use \columnb (two-column mode) - \global\setbox\columnb\hbox to -\intercolumnskip{} - \else - \global\setbox\columnb\columnbox \global\def\abc{c}\fi\fi} - \def\multicolumnformat{\shipout\vbox{\makeheadline - \hbox{\box\columna\hskip\intercolumnskip - \box\columnb\hskip\intercolumnskip\columnbox} - \makefootline}\advancepageno} - \def\columnbox{\leftline{\pagebody}} - - \def\bye{\par\vfill\supereject - \if a\abc \else\null\vfill\eject\fi - \if a\abc \else\null\vfill\eject\fi - \end} -\fi - -% we won't be using math mode much, so redefine some of the characters -% we might want to talk about -\catcode`\^=12 -\catcode`\_=12 - -\chardef\\=`\\ -\chardef\{=`\{ -\chardef\}=`\} - -\hyphenation{mini-buf-fer} - -\parindent 0pt -\parskip 1ex plus .5ex minus .5ex - -\def\small{\smallfont\textfont2=\smallsy\baselineskip=.8\baselineskip} - -\outer\def\newcolumn{\vfill\eject} - -\outer\def\title#1{{\titlefont\centerline{#1}}\vskip 1ex plus .5ex} - -\outer\def\section#1{\par\filbreak - \vskip 3ex plus 2ex minus 2ex {\headingfont #1}\mark{#1}% - \vskip 2ex plus 1ex minus 1.5ex} - -\newdimen\keyindent - -\def\beginindentedkeys{\keyindent=1em} -\def\endindentedkeys{\keyindent=0em} -\endindentedkeys - -\def\paralign{\vskip\parskip\halign} - -\def\<#1>{$\langle${\rm #1}$\rangle$} - -\def\kbd#1{{\tt#1}\null} %\null so not an abbrev even if period follows - -\def\beginexample{\par\leavevmode\begingroup - \obeylines\obeyspaces\parskip0pt\tt} -{\obeyspaces\global\let =\ } -\def\endexample{\endgroup} - -\def\key#1#2{\leavevmode\hbox to \hsize{\vtop - {\hsize=.75\hsize\rightskip=1em - \hskip\keyindent\relax#1}\kbd{#2}\hfil}} - -\newbox\metaxbox -\setbox\metaxbox\hbox{\kbd{M-x }} -\newdimen\metaxwidth -\metaxwidth=\wd\metaxbox - -\def\metax#1#2{\leavevmode\hbox to \hsize{\hbox to .75\hsize - {\hskip\keyindent\relax#1\hfil}% - \hskip -\metaxwidth minus 1fil - \kbd{#2}\hfil}} - -\def\threecolumn#1#2#3{\hskip\keyindent\relax{#1}\hfil&{#2}\quad &{#3}\quad\cr} -\def\threecol#1#2#3{\threecolumn{#1}{\kbd{#2}}{\kbd{#3}}} - -%**end of header - - -\title{Tree Dired Reference Card} - -\centerline{(for GNU Emacs version 18)} - -\centerline{$ !Id: dired-ref.tex,v 1.1.1.1 1992/06/29 22:33:08 devin Exp ! $} - -A feature marked like this\diredx{} is optional and not part of dired -proper. - - -\section{Starting Dired} - -\key{Dired in current window} {C-x d} -\key{Dired in other window} {C-x 4 d} - -The last component of the pathname may contain wildcards. With prefix -argument, Dired asks you to enter the listing switches for the {\tt -ls} command. - -Another way is from within {\tt find-file}, \kbd{C-x C-f}: just enter -a directory name (no wildcards possible). - - -\section {Cursor Motion} -All the usual Emacs cursor motion commands are available in Dired -buffers. Special motion commands are (see also ``Subdirectories'' -below): - -\beginindentedkeys -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\cr -\threecol{\bf go to} {\bf previous} {\bf next} -\threecol{line} {C-p {\rm or} p} {C-n {\rm or} n} -\threecol{directory line} {<} {>} -%\threecol{inserted directory} {ESC C-p} {ESC C-n} % now below -\threecol{marked file} {ESC \{} {ESC \}} -} -\endindentedkeys - - -\section{Visiting Files} - -\key{visit current file (dired if directory)} {f} -\key{visit current file in other window}{o} -\key{view current file read-only} {v} - - -\section{Displaying Files} - -\key{toggle between sort by name/date} {s} -\key{specify new ls switches}{C-u s} -\key{redisplay current, marked or next N files}{l} -\key{revert buffer}{g} - -\key{kill this line (but not this file)}{k} -\key{undo changes to Dired buffer} {C-x u {\rm or} C-_} -\key{copy file name(s) to kill ring\diredx} {w} - - -\section{Marking and Unmarking Files} - -\key{mark (with \kbd{*}) the current or next N file(s)} {m} -\key{remove mark}{u} -\key{remove mark on previous line}{DEL} - -\key{mark all files matching REGEXP}{\%m} -\key{mark all executable files}{*} -\key{mark all symbolic links}{@} -\key{mark all directories}{/} - -\key{unmark the current or next N file(s)} {u} -\key{move up lines and remove flags there} {DEL} -\key{remove a specific or all flags from every file}{ESC DEL} -%\key{toggle marks\diredx}{T} % this command is not very important - - -\section {Mark Using Commands} - -The following commands are applied to the marked files or (if there -are none) to the current file. Numeric prefix argument means, apply -command to the next N (previous N if negative) files. Digits work as -prefix arguments. - -{\bf Copying And Moving Files\dots} - -Default target directory is where point is. - -\beginindentedkeys -\key{move or rename} {r} -\key{copy} {c} -\key{make hard links} {H} -\key{make symbolic links} {Y} -\key{make relative symbolic links\diredx} {S} -\endindentedkeys - -{\bf \dots With Regexps} - -{\tt \\\&} in NEWNAME stands for the entire text being replaced. {\tt -\\N} in NEWNAME, where N is a digit, stands for whatever matched the -N'th parenthesized grouping in REGEXP. - -\beginindentedkeys -\key{move or rename} {\%r} -\key{copy} {\%c} -\key{make hard links} {\%H} -\key{make symbolic links} {\%Y} -\key{make relative symbolic links\diredx} {\%S} - -\key{rename to upper case}{\%u} -\key{rename to lower case}{\%l} -\endindentedkeys - -{\bf Shell Commands} - -Shell commands have the top level directory as working directory. -A {\tt *} indicates where filenames go (default: at end). - -\beginindentedkeys -\key{run a shell command}{!} -\key{run a shell command in background\diredx}{\&} -\endindentedkeys - -{\bf Other Mark Using Commands} - -\beginindentedkeys -\key{compress files}{C} -\key{uncompress files}{U} - -\key{change the mode ({\tt g+w} etc. allowed)} {M} -\key{change the group} {G} -\key{change the owner} {O} - -\key{load elisp files}{L} -\key{byte compile elisp files} {B} - -\key{print files} {P} -\endindentedkeys - - -\section {Deleting Files} - -\key{flag (with \kbd{D}) file for deletion}{d} - -\key{flag auto-save files}{\#} -\key{flag backup files}{\~} -\key{flag excess numeric backup files}{.} -\key{flag files matching REGEXP}{\%d} - -\key{delete \kbd{D}-flagged files}{x} -\key{delete \kbd{*}-marked files} {X} - - -\section{Comparing files} - -\key{diff current file with file mark is on} {D} -\key{diff current file with its backup file} {ESC \~} - - -\section{Making Directories} - -\key{create a new directory}{+} - - -\section{Error Logging} - -\key{see why something went wrong}{W} - - -\section{Subdirectories} - -\key{insert directory into same Dired buffer}{i} -\key{insert all marked directories\diredx}{I} - -\key{relist subdirectory of this headerline}{l} -\key{kill subdirectory of this headerline}{k} - -\key{go up (Dired parent directory)}{^} -\key{go down (view this directory)}{v} - -\key{go up in inserted directory tree}{ESC C-u} -\key{go down in inserted directory tree}{ESC C-d} -\key{next inserted directory}{ESC C-n} -\key{previous inserted directory}{ESC C-p} - - -\section{Hiding Directories} -\key{hide or unhide current inserted directory}{\$} -\key{hide or unhide all inserted directories}{=} - - -\section{Advanced Commands\diredx} - -%{\bf Dynamic Markers} -%\section{Dynamic Markers\diredx} - -\key{push a new marker character}{(} -\key{pop current marker off stack}{)} - -%{\bf Omitting} -%\section{Omitting\diredx} - -\key{toggle omitting}{ESC o} - -%{\bf Advanced Mark Commands} -%\section{Advanced Mark Commands\diredx} - -\key{mark files for which PREDICATE is non-nil}{ESC (} - -{\beginindentedkeys -\advance\leftskip by \keyindent -% -PREDICATE is a lisp expression, e.g., {\tt (= size 0)}, that can refer -to the following symbols: - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\cr -\threecolumn{\bf meaning} {\bf symbol} {\bf type} -\threecolumn{inode (only for {\tt ls -i})} {\tt inode}{\rm integer} -\threecolumn{size, usually in blocks (only for {\tt ls -s})}{\tt s}{\rm integer} -\threecolumn{file permission bits ({\tt "-rw-r--r--"})}{\tt mode}{\rm string} -\threecolumn{number of links to file} {\tt nlink}{\rm integer} -\threecolumn{owner} {\tt uid}{\rm string} -\threecolumn{group} {\tt gid}{\rm string} -\threecolumn{file size in bytes} {\tt size}{\rm integer} -\threecolumn{time that {\tt ls} displays ({\tt "Feb 12 14:17"})}{\tt time}{\rm string} -\threecolumn{name of the file} {\tt name}{\rm string} -\threecolumn{if symlink, linked-to name, else {\tt ""}}{\tt sym}{\rm string} -} -\endindentedkeys -} - -\section{Filename Transformers\diredx} -Use e.g. {\tt [b]} instead of {\tt *} to access basenames in shell -commands. - -\key{unmodified filename (equivalent to {\tt [dbe]}).}{*} -\key{name without directory information}{n} -\key{directory component}{d} -\key{basename, without directory and extension}{b} -\key{extension}{e} -\key{file without directory and without {\tt,v} suffix.}{v} -\key{without directory and without {\tt .Z} suffix}{z} - - -\section{Find Dired\diredx} - -\metax{Feed arbitrary find(1) command to Dired}{M-x find-dired} -\metax{Find file names matching WILDCARD}{M-x find-name-dired} -\metax{Find files containing PATTERN}{M-x find-grep-dired} - -\bye diff -r 498bf5da1c90 -r 0d2f883870bc man/dired.texi --- a/man/dired.texi Mon Aug 13 09:12:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3334 +0,0 @@ -\input texinfo @c -*-texinfo-*- - -@comment !Date: 1993/12/21 22:31:56 ! !Revision: 1.1 ! - -@comment %**start of header (This is for running Texinfo on a region.) -@setfilename ../info/dired.info -@settitle Tree Dired Version 6 -@c @setchapternewpage odd -@comment %**end of header (This is for running Texinfo on a region.) - -@iftex -@finalout -@end iftex - -@ifinfo -This file documents Tree Dired, the GNU Emacs Directory Browser, and -most of the extra features available as an option. - -Copyright (C) 1991, 1992 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of this -manual provided the copyright notice and this permission notice are -preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission notice -identical to this one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -section entitled ``GNU General Public License'' is included exactly as -in the original, and provided that the entire resulting derived work is -distributed under the terms of a permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the section entitled ``GNU General Public License'' may be -included in a translation approved by the author instead of in the -original English. -@end ifinfo - -@titlepage -@sp 6 -@center @titlefont{Tree Dired} -@sp 2 -@center @titlefont{The GNU Emacs} -@sp 1 -@center @titlefont{Directory Editor} -@sp 4 -@c @@center !Date: 1993/12/21 22:31:56 ! -@sp 1 -@c @@center !Revision: 1.1 ! -@sp 5 -@center Sebastian Kremer -@center sk@@thp.uni-koeln.de - -@page - -@noindent -!Date: 1993/12/21 22:31:56 ! - -@noindent -!Revision: 1.1 ! - -@vskip 0pt plus 1filll -Copyright @copyright{} 1991, 1992 Free Software Foundation - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission notice -identical to this one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -section entitled ``GNU General Public License'' is included exactly as -in the original, and provided that the entire resulting derived work is -distributed under the terms of a permission notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the section entitled ``GNU General Public License'' may be -included in a translation approved by the author instead of in the -original English. -@end titlepage - -@ifinfo - -@node Top, Dired, (dir), (dir) - -This file documents Tree Dired (version 6), the GNU Emacs Directory -Editor, including the optional ``Dired Extra'' features. - -Tree Dired is an enhanced version of the Classic (18.xx Emacs) Dired and -will be the Dired of Emacs 19. It is known to work with Emacs 18.55 and -18.57 (and probably most earlier versions). -@c and also with prerelease versions of Emacs 19, but I don't write that -@c since I don't want to be bombarded with questions like `when it will -@c be ready'... - -@noindent -Revision of this manual: - -@noindent -!Id: dired.texinfo,v 1.1 1993/12/21 22:31:56 jwz Exp ! - -@noindent -Report bugs to: -@example -Sebastian Kremer -@end example - -@menu -* Dired:: Dired, the Directory Editor -* Tree Dired Extra:: Tree Dired Extra features -* Dired Internals:: Dired Internals -* Dired Known Problems:: Known Problems with Dired - - --- Indices --- - -* Dired Variable Index:: -* Dired Function Index:: -* Dired Key Index:: -* Dired Concept Index:: - - --- The Detailed Node Listing --- - -Dired, the Directory Editor - -* Entering Dired:: -* Editing in Dired:: -* Listing Files in Dired:: -* Marking Files in Dired:: -* Mark-using Commands:: -* Commands That Do Not Use Marks:: -* Subdirectories in Dired:: -* Hiding Directories in Dired:: -* Acknowledgement:: -* Dired Customization:: - -Mark-using Commands - -* Copy and Move Into a Directory:: -* Renaming and More With Regexps:: -* Other File Creating Commands:: -* Deleting Files With Dired:: -* Dired Shell Commands:: -* Compressing and Uncompressing:: -* Changing File Attributes:: -* Loading and Byte-compiling Emacs Lisp Files:: -* Printing the Marked Files:: - -Dired Customization - -* Dired User Options:: -* Dired Configuration:: -* Dired Hooks:: - -Tree Dired Extra features - -* Tree Dired Extra Features:: -* Dired Minibuffer History:: -* Inserting All Marked Subdirectories:: -* Dynamic Dired Markers:: -* Omitting Files in Dired:: -* Advanced Dired Mark Commands:: -* Virtual Dired:: -* Multiple Dired Directories:: -* Dired Local Variables:: -* Making Relative Symbolic Links in Dired:: -* Letting Dired Guess What Shell Command to Apply:: -* dired-trns.el:: Filename Transformers for Dired Shell Commands -* dired-cd.el:: Changing the Working Directory for Dired Shell Commands -* dired-nstd.el:: Nested Dired format -* find-dired.el:: Feeding Find Output to Dired - -Dired Internals - -* Tree Dired Internals:: -* Dired Mark Internals:: -@end menu - -@end ifinfo - -@node Dired, Tree Dired Extra, Top, Top -@chapter Dired, the Directory Editor -@cindex Dired -@cindex Deletion (of files) - -Dired makes it easy to delete or visit many of the files in a single -directory (and possibly its subdirectories) at once. It makes an Emacs -buffer containing a listing of the directories, in the format of -@code{ls -lR}. You can use the normal Emacs commands to move around in -this buffer, and special Dired commands to operate on the files. You -can run shell commands on files, visit, compress, load or byte-compile -them, change their file attributes and insert subdirectories into the -same buffer. You can ``mark'' files for later commands or ``flag'' them -for deletion, either file by file or all files matching certain -criteria. - -@menu -* Entering Dired:: -* Editing in Dired:: -* Listing Files in Dired:: -* Marking Files in Dired:: -* Mark-using Commands:: -* Commands That Do Not Use Marks:: -* Subdirectories in Dired:: -* Hiding Directories in Dired:: -* Acknowledgement:: -* Dired Customization:: -@end menu - -@node Entering Dired, Editing in Dired, Dired, Dired -@section Entering Dired - -@findex Dired -@kindex C-x d -@vindex dired-listing-switches -@noindent -To invoke Dired, do @kbd{C-x d} or @kbd{M-x dired}. The command reads a -directory name or wildcard file name pattern as a minibuffer argument -just like the @code{list-directory} command, @kbd{C-x C-d}. Invoking -Dired with a prefix argument lets you enter the listing switches for the -directory. - -Dired assumes you meant to use a wildcard if the last component of the -name is not an existing file. Note that only the last pathname -component may contain wildcards. With wildcards it uses the shell to do -the filename globbing, whereas usually it calls @samp{ls} directly. -Because of this, you might have to quote characters that are special to -the shell. For example, to dired all auto-save files in your -@file{~/mail/} directory, use @samp{~/mail/\#*} as argument to Dired. -Note the backslash needed to quote @samp{#} (at the beginning of a word) -to the shell. - -Where @code{dired} differs from @code{list-directory} is in naming the -buffer after the directory name or the wildcard pattern used for the -listing, and putting the buffer into Dired mode so that the special -commands of Dired are available in it. The variable -@code{dired-listing-switches} is a string used as an argument to -@code{ls} in making the directory; this string @i{must} contain -@samp{-l}. Most other switches are also allowed, especially @samp{-F}, -@samp{-i} and @samp{-s}. For the @samp{-F} switch to work you may have -to set the variable @code{dired-ls-F-marks-symlinks}, depending on what -kind of @samp{ls} program you are using. -@xref{Dired Configuration}. -@refill - -When a Dired buffer for the given directory already exists, it is simply -selected without refreshing it. You can type @kbd{g} if you suspect it -is out of date. - -@findex dired-other-window -@kindex C-x 4 d -To display the Dired buffer in another window rather than in the -selected window, use @kbd{C-x 4 d} (@code{dired-other-window)} instead -of @kbd{C-x d}.@refill - -@node Editing in Dired, Listing Files in Dired, Entering Dired, Dired -@section Editing in Dired - -@noindent -Once the Dired buffer exists, you can switch freely between it and other -Emacs buffers. Whenever the Dired buffer is selected, certain special -commands are provided that operate on files that are listed. The Dired -buffer is ``read-only'', and inserting text in it is not useful, so -ordinary printing characters such as @kbd{d} and @kbd{x} are used for Dired -commands, and digits are prefix arguments.@refill - -@cindex Current file (in Dired) -The file described by the line that point is on is called the -@dfn{current file}. The directory this file is in is the @dfn{current -Dired directory}. Note that there may be several directories in one -Dired buffer as long as they belong to the same tree. The top level -directory, the @dfn{root} of the tree, is used as the working directory -of the buffer.@refill - -Some or all directories can be @dfn{hidden}, leaving only their -headerlines visible, and exlcuding their files from Dired operations. - -@cindex Marking files (in Dired) -Files can be @dfn{marked} for later commands. Marking means putting a -special character, usually @samp{*}, in the first column of the file -line. To @dfn{flag} a file means to mark it for later deletion. This -special case of ``marking'' is distinguished so that you do not delete -files accidentally. Internally, the only difference between marking and -flagging is the character used to mark the file: @samp{*} (an asterisk) -for a marked file, and @samp{D} for files flagged for deletion. - -@cindex Mark-using commands -Most Dired commands operate on the ``marked'' files and default to the -current file. They are the @dfn{mark-using} commands. Deleting is the -only mark-using command that does not default to the current file. - -Dired buffers ``know'' about each other. For example, copying from -@var{dir1} into @var{dir2} will update @var{dir2}'s Dired buffer(s). -When you move files or directories, file and dired buffers are kept up -to date and refer to the new location. But Dired only knows about files -changed by itself, not by other parts of Emacs or programs outside -Emacs. - -All the usual Emacs cursor motion commands are available in Dired -buffers. Some special purpose commands are also provided. The keys -@kbd{C-n} and @kbd{C-p} are redefined so that they try to position the -cursor at the beginning of the filename on the line, rather than at the -beginning of the line. - -For extra convenience, @key{SPC} and @kbd{n} in Dired are equivalent to -@kbd{C-n}. @kbd{p} is equivalent to @kbd{C-p}. Moving by lines is also -done so often in Dired that it deserves to be easy to type. @key{DEL} -(move up and unflag) is often useful simply for moving up.@refill - -@node Listing Files in Dired, Marking Files in Dired, Editing in Dired, Dired -@section Listing Files in Dired - -@cindex Headerline -@cindex Non-file line -@cindex File line -@noindent -Initially the Dired buffer shows the directory you selected. The first -line shows the full directory name. It is an example of a -@dfn{headerline} of a directory. Note that it is terminated by a colon -(@samp{:}) that is not part of the directory name. The second line -usually displays the total size of all files in the directory or -the wildcard used. Both are examples of @dfn{non-file lines}. -Applying a command to a non-file line signals an error. The other lines -of the directory, called the @dfn{file lines}, show information about -each file such as permission bits, size and date of last modification, -and the name of the file.@refill - -For example, the listing - -@example - /home/sk/lib/emacs/lisp: - total 4973 - -rw-r--r-- 1 sk users 231608 Feb 6 16:58 ChangeLog - drwxr-sr-x 2 sk users 2048 Feb 6 11:07 RCS - -r--r--r-- 1 sk users 141389 Feb 6 10:45 dired.el - -r--r--r-- 1 sk users 113033 Feb 5 16:21 dired.texi - @dots{} - - /home/sk/lib/emacs/lisp/RCS: - total 4798 - -r--r--r-- 1 sk users 231748 Feb 6 16:59 dired.texi,v - -r--r--r-- 1 sk users 763898 Feb 6 10:45 dired.el,v - @dots{} -@end example - -has a headerline for the @file{lisp} directory, a total line saying -there are 4973 K in all the files of that directory (your @samp{ls} -program may use units of blocks instead), and several file lines. After -that, a headerline for the @file{RCS} subdirectory with its total line -and its files follows. - -Here is an example of a wildcard listing: - -@example - /home/sk/lib/emacs/lisp: - wildcard dired* - -rw-r--r-- 1 sk users 113036 Feb 6 16:59 dired.texi - -r--r--r-- 1 sk users 81267 Feb 6 16:29 dired.elc - -r--r--r-- 1 sk users 38436 Feb 6 16:28 dired-x.elc - -r--r--r-- 1 sk users 60258 Feb 6 16:27 dired-x.el - -r--r--r-- 1 sk users 141389 Feb 6 10:45 dired.el - @dots{} -@end example - -Since @samp{ls} does not provide a total count when called with a wildcard -argument, the second line now gives instead the wildcard used, here -@samp{dired*}. If there would have been a directory matching the -wildcard, e.g. a @samp{dired/} subdirectory, its file line would be -shown, but it would not have been expanded automatically. - -Filenames may have embedded and trailing (but not leading) spaces. -Leading spaces are not recognized because different @samp{ls} programs -differ in the amount of whitespace the insert before the filename. -Filenames may @emph{not} contain newlines or @samp{^M}'s. You can get -away with @samp{^M}'s in filenames if you do - -@example - (setq selective-display nil) -@end example - -@noindent -in the Dired buffer (inside @code{dired-mode-hook}, @xref{Dired -Hooks}.). But this also disables the @kbd{=} and @kbd{$} hiding -commands, @xref{Hiding Directories in Dired}.@refill - -Other unprintable characters than @samp{^M} or newline (@samp{^J}) in -filenames are no problem for Dired. But your @samp{ls} program may not -output them correctly (e.g., replacing all unprintable characters with a -question mark @samp{?}). Dired can do nothing if @samp{ls} suppresses -information about the filenames. But some (System V derived) @samp{ls} -programs have a @samp{-b} switch to quote control characters, e.g. -@samp{\n} for a newline character, or @samp{\007} for a ASCII bell -character (@kbd{C-g}), so you might want to add @samp{b} to your -switches (see below). Dired translates the quoted control character -escapes when a @samp{-b} switch was used. The @samp{-b} switch is the -recommended method to cope with funny filenames containing newlines or -leading spaces. But check if your @samp{ls} understands @samp{-b} and really -quotes newlines and spaces. Dired is known to work with GNU @samp{ls --b}, but other @samp{ls -b} don't quote spaces, so leading spaces still -don't work with these @samp{ls} programs. -@refill - -The appearance of the listing is determined by the listing switches -used, for example whether you display or suppress @samp{.} files with -the @samp{-a} and @samp{-A} switches, use the @samp{-F} switch to tag -filenames etc. It may additionally be restricted to certain files if you -used wildcards to display only those files matching a shell file -wildcard.@refill - -@cindex Dired listing switches -Dired has commands that change the listing switches for this buffer. -They are mainly used to set the sort mode, but can also be used to -change other formatting options. The buffer is automatically refreshed -after the switches are changed to let the new format take effect. - -The default value for the switches comes from the variable -@code{dired-listing-switches}; a prefix argument to @code{dired} can be -use to determine the switches used for a specific buffer. -@xref{Entering Dired}. Each Dired buffer has its own value for the -switches, stored in the variable @code{dired-actual-switches}.@refill -@vindex dired-actual-switches - -@vindex dired-sort-by-name-regexp -@vindex dired-sort-by-date-regexp -The Dired modeline displays @samp{by name} or @samp{by date} to indicate -the sort mode. It uses the regexps in the variables -@code{dired-sort-by-date-regexp} and @code{dired-sort-by-name-regexp} to -decide what should be displayed. If neither of the regexps matches, the -listing switches are displayed literally. You can use this to always -display the literal switches instead of @samp{by name} or @samp{by -date}: set them to a regexp that never matches any listing switches, for -example @samp{^$}.@refill - -@vindex dired-ls-sorting-switches -Most @samp{ls} programs can only sort by name (without @samp{-t}) or by -date (with @samp{-t}), nothing else. GNU @samp{ls} additionally sorts -on size with @samp{-S}, on extension with @samp{-X}, and unsorted (in -directory order) with @samp{-U}. So anything that does not contain -these is sort "by name". However, this is configurable in the variable -@code{dired-ls-sorting-switches}, which defaults to @code{"SXU"}. It -contains a string of @samp{ls} switches (single letters) except @samp{t} that -influence sorting. It is consulted at load time, so if you redefine it, -you must do it before Dired is loaded.@refill - -@table @kbd - -@item s -@kindex s -@findex dired-sort-toggle-or-edit -(@code{dired-sort-toggle-or-edit}) Toggle between sort by name/date and -refresh the dired buffer. With a prefix argument you can edit the -current listing switches instead. - -@end table - -@cindex Refreshing a Dired listing -After some time the listing may become out of date because of actions by -other programs than Dired. You can refresh the complete Dired buffer -from disk or only refresh the lines of certain files or a single file. - -@table @kbd - -@item l -@kindex l -@findex dired-do-redisplay -(@code{dired-do-redisplay}) Redisplay all marked (or, with a prefix -argument, the next @var{N}) files. As always, if no files are marked, -the current file is used. - -If on a headerline, redisplay that subdirectory. In that case, -a prefix arg lets you edit the @samp{ls} switches used for the new listing. - - -@kindex g -@findex revert-buffer -@item g -(@code{revert-buffer}) The @kbd{g} command in Dired ultimately runs -@code{dired-revert} to reinitialize the buffer from the actual disk -directory (or directories). All marks and flags in the Dired buffer are -restored, except of course for files that have vanished. Hidden -subdirectories are hidden again. @xref{Hiding Directories in Dired}. -@refill - -@item k -@kindex k -@findex dired-kill-line-or-subdir -(@code{dired-kill-line-or-subdir}) Kill this line (but not this file). -Optional prefix argument is a repeat factor. -If file is displayed as expanded subdirectory, kill that as well. - -If on a subdirectory line, kill that subdirectory. Reinsert it with -@kbd{i} (@code{dired-maybe-insert-subdir}), @xref{Subdirectories in -Dired}. - -Killing a file line means that the line is removed from the Dired -buffer. The file is not touched, and the line will reappear when the -buffer is refreshed (using @kbd{g}, @code{revert-buffer}). A killed -subdirectory will not reappear after reverting the buffer, since @kbd{g} -only list those subdirectories that were listed before. - -@item M-k -@kindex M-k -@findex dired-do-kill -(@code{dired-do-kill}) Kill all marked lines (not files). With a prefix -argument, kill all lines not marked or flagged. - -(For file marking, @xref{Marking Files in Dired}.) - -@item C-x u -@kindex C-x u -@item C-_ -@kindex C-_ -@findex dired-undo -(@code{dired-undo}) Undo in a Dired buffer. This doesn't recover lost -files, it is just normal undo with a temporarily writable buffer. You -can use it to recover marks, killed lines or subdirs. In the latter -case, you have to do @kbd{M-x dired-build-subdir-alist} to parse the -buffer again for the new subdirectory list.@refill - -@end table - - -@node Marking Files in Dired, Mark-using Commands, Listing Files in Dired, Dired -@section Marking Files in Dired - -@noindent -This section describes commands to mark and unmark single files, and -commands to mark several files at once if they match certain criteria. -There also is a command to move to the next marked file. - -As always, hidden subdirs are not affected. @xref{Hiding Directories in -Dired}. - -@table @kbd - -@item m -@kindex m -@findex dired-mark-subdir-or-file -(@code{dired-mark-subdir-or-file}) If on a file line, mark the current -file. A numeric argument tells how many next or previous files to mark. -If on a subdirectory header line, mark all its files except `.' and `..'. - -@item u -@kindex u -@findex dired-unmark-subdir-or-file -(@code{dired-unmark-subdir-or-file}) Like @kbd{m}, only unmarking -instead of marking. - -@item DEL -@kindex DEL -@findex dired-backup-unflag -(@code{dired-backup-unflag}) Move up lines and remove flags there. -Optional prefix argument says how many lines to unflag; default is one -line. - -@item M-DEL -@kindex M-DEL -@findex dired-unflag-all-files -(@code{dired-unflag-all-files}) Remove a specific or all flags from -every file. With an argument, queries for each marked file. Type your -help character, usually -@kbd{C-h}, at that time for help. - -@item * -@kindex * -@findex dired-mark-executables -(@code{dired-mark-executables}) Mark all executable files. With prefix -argument, unflag all those files. - -@item @@ -@kindex @@ -@findex dired-mark-symlinks -(@code{dired-mark-symlinks}) Mark all symbolic links. With prefix -argument, unflag all those files. - -@item / -@kindex / -@findex dired-mark-directories -(@code{dired-mark-directories}) Mark all directory files except `.' and -`..'. With prefix argument, unflag all those files. - -@item %m -@kindex %m -@findex dired-mark-files-regexp -(@code{dired-mark-files-regexp}) Mark all files matching @var{regexp} -for use in later commands. A prefix argument means to unmark them -instead. @file{.} and @file{..} are never marked. - -The match is against the non-directory part of the filename. Use -@samp{^} and @samp{$} to anchor matches. Exclude subdirs by hiding -them. - -This is an Emacs regexp, not a shell wildcard. E.g., use @samp{\.o$} -for object files - just @samp{.o} will mark more than you might think. -By default, the match is case sensitive (just like filenames), since -@code{case-fold-search} is set to @code{nil} in Dired buffers. - -@item M-@} -@kindex M-@} -@findex dired-next-marked-file -(@code{dired-next-marked-file}) Move to the next marked file, wrapping -around the end of the buffer. - -@item M-@{ -@kindex M-@{ -@findex dired-prev-marked-file -(@code{dired-prev-marked-file}) Move to the previous marked file, -wrapping around the beginning of the buffer. - -@end table - -@node Mark-using Commands, Commands That Do Not Use Marks, Marking Files in Dired, Dired -@section Mark-using Commands - -@cindex Mark-using commands -Most Dired commands operate on the ``marked'' files and default to the -current file. They are the ``mark-using'' commands. Deleting is the -only mark-using command that does not default to the current file. - -@cindex Numeric argument to Dired's mark-using commands -@cindex Prefix argument to Dired's mark-using commands -@cindex Repeat count for Dired's mark-using commands -@cindex Mark-using commands, use of prefix argument as repeat count -Mark-using Dired commands treat a numeric argument as a repeat count, -meaning to act on the files of the next few lines instead of on the -marked files. That is, when you give a prefix argument the marks are -not consulted at all. A negative argument means to operate on the files -of the preceding lines. Either set of files is called @dfn{marked -files} below, whether they really come from marks or from a prefix -argument. The prompt of a mark-using command always makes clear which -set of files is operated upon: it mentions either the marker character -@samp{*} or the @samp{next @var{N}} files, where a negative @var{N} -really means the previous @var{-N} files.@refill - -@cindex Prefix argument via digit keys -Thus you can use a prefix argument of @code{1} to apply a command to just the -current file, e.g, if you don't want to disturb the other files you -marked. As digits are prefix arguments in Dired, simply type @kbd{1} -followed by the command. - -Many mark-using commands treat a prefix of @var{N=0} specially, since it -would otherwise be a no-op. - -@cindex Why something went wrong in Dired -@cindex Error logging in Dired -@kindex W -All mark-using commands display a list of files for which they failed. -Type @kbd{W} to see why a (mark-using or other) command failed. Error -messages from shell commands (@samp{stderr}) cannot be redirected -separately and goes together with the usual output (@samp{stdout}). - -@menu -* Copy and Move Into a Directory:: -* Renaming and More With Regexps:: -* Other File Creating Commands:: -* Deleting Files With Dired:: -* Dired Shell Commands:: -* Compressing and Uncompressing:: -* Changing File Attributes:: -* Loading and Byte-compiling Emacs Lisp Files:: -* Printing the Marked Files:: -@end menu - -@node Copy and Move Into a Directory, Renaming and More With Regexps, Mark-using Commands, Mark-using Commands -@subsection Copy, Move etc. Into a Directory - -@cindex Target commands in Dired -@cindex Dired target commands -@noindent -This section explains commands that create a new file for each marked -file, for example by copying (@kbd{c}) or moving (@kbd{r}) files. They -prompt in the minibuffer for a @var{target} argument, usually the target -directory in which the new files are created. But if there is but one -marked file, the target may also be a plain file. (Otherwise you could -not simply rename or copy a single file within the same directory.) -Even with one marked file the target may still be an (existing) -directory. - -@cindex Target default in Dired -@cindex Default target in Dired -@vindex dired-dwim-target -The target prompt displays a @dfn{default target} that will be used if -you just type @kbd{RET}. Normally the default target is the current -Dired directory, so if you want to copy into some specific subdirectory, -move point into that subdirectory before typing @kbd{c}. But if there -is a Dired buffer in the next window, and @code{dired-dwim-target} is -true, its current Dired directory is used. This makes it easy to copy -from one Dired buffer into another if both are displayed. On the other -hand you have to use @kbd{C-x 1} to make other Dired buffers vanish if -you do not want to have them as default targets. To make Dired never -look at the next window, set the variable @code{dired-dwim-target} to -nil (@samp{dwim} means Do What I Mean). @xref{Dired User Options}, on -how to set cutomization variables. - -@cindex Overwriting of files in Dired -As a general rule, Dired will not let you remove or overwrite a file -without explicit confirmation. Dired asks you for each existing target -file whether or not to overwrite just this file (answer @kbd{y} or -@kbd{n}) or all remaining files (answer @kbd{!}). You can also type -your help character, usually @kbd{C-h}, at that time for help. - -@table @kbd -@findex dired-do-copy -@kindex c -@vindex dired-copy-preserve-time -@item c -(@code{dired-do-copy}) Copy the marked (or next @var{N}) files into a -directory, or copy a single file. - -Thus, a zero prefix argument (@var{N-0}) copies nothing. But it toggles -the variable @code{dired-copy-preserve-time}.@* -@xref{Dired User Options}, on how to set customization variables. - -@findex dired-do-move -@kindex r -@item r -(@code{dired-do-move}) Move the marked files into a directory. If -there is just one marked file, rename that file. As the marked files -default to the current file, this can also be used to simply rename the -current file. - -Dired silently changes the visited file name of buffers associated with -moved files so that they refer to the new location of the file. - -When a directory is renamed, its headerlines in Dired buffers are -updated, and any buffers visiting affected files have their visited file -name changed to refer to the new location. Their buffer name is changed -if no buffer with such a name already exists. Affected files are all -those which contain the directory somewhere in their absolute path name. - -A zero prefix arguments does not move any files, but toggles the -variable @code{dired-dwim-target}. - -@findex dired-do-hardlink -@kindex H -@item H -(@code{dired-do-hardlink}) Make hard links from the target directory -to each marked file. -@findex dired-do-symlink -@kindex Y -@item Y -(@code{dired-do-symlink}) Make symbolic links from the target -directory to each marked file. -@end table - -@vindex dired-keep-marker-copy -@vindex dired-keep-marker-hardlink -@vindex dired-keep-marker-symlink -Linking is very similar to copying in that new files are created while -the old files stay. If you want each newly copied or linked file to be -marked with the same marker that its original has, set the variables -@code{dired-keep-marker-copy}, @code{dired-keep-marker-hardlink} or -@code{dired-keep-marker-symlink} to @code{t}. Set them to @code{nil} to -not give these newly created files marks. The default is to mark them -with @samp{C}, @samp{H} and @samp{Y}, respectively. - -@vindex dired-keep-marker-move -Moving differs from copying and linking in that the old file is removed -as part of the creation of the new file. Thus it makes sense to set the -variable @code{dired-keep-marker-move} to @code{t} (the default) so that -moved files ``take their markers with them''. - -@node Renaming and More With Regexps, Other File Creating Commands, Copy and Move Into a Directory, Mark-using Commands -@subsection Renaming (and More) With Regexps - -@cindex Regexp commands in Dired -@cindex Dired regexp commands -A second class of Commands uses regular expressions to construct a new -filename from each marked file. @xref{Regexps,Syntax of Regular -Expressions,Regular Expressions,emacs,The GNU Emacs Manual}. The commands -to make new names by regexp conversion are the same as those to make -them in another directory, except that they share a prefix char, @kbd{%}. - -@table @kbd - -@item %r -@kindex %r -@findex dired-rename-regexp -(@code{dired-rename-regexp}) Rename files with regexps - -@item %c -@kindex %c -@findex dired-do-copy-regexp -(@code{dired-do-copy-regexp}) -Copy files with regexps. - -@item %H -@kindex %H -@findex dired-do-hardlink-regexp -(@code{dired-do-hardlink-regexp}) -Make hard links with regexps. - -@item %Y -@kindex %Y -@findex dired-do-symlink-regexp -(@code{dired-do-symlink-regexp}) -Make symbolic links with regexps. - -@end table - -These commands prompt in the minibuffer for a @var{regexp} and a -@var{newname}. For each marked file matching @var{regexp}, a new -filename is constructed from @var{newname}. The match can be anywhere -in the file name, it need not span the whole filename. Use @samp{^} and -@samp{$} to anchor matches that should span the whole filename. Only -the first match in the filename is replaced with @var{newtext}. (It -would be easy to change this to replace all matches, but probably harder -to use.) - -@samp{\&} in @var{newname} stands for the entire text being replaced. -@samp{\@var{d}} in @var{newname}, where @var{d} is a digit, stands for -whatever matched the @var{d}'th parenthesized grouping in @var{regexp}. -As each match is found, the user must type a character saying whether or -not to apply the command to just this file (@kbd{y} or @kbd{n}) or to -all remaining files(@kbd{!}). For help type your help character, -usually @kbd{C-h}, at that time.@refill - -For example, if you want to rename all @file{.lsp} files to @file{.el} -files, type first @kbd{%m} with @samp{\.lsp$} as regexp to mark all -@file{.lsp} files. Then type @kbd{%r} with @samp{\.lsp$} and @samp{.el} -as @var{regexp} and @var{newtext} arguments. Dired will prompt you for -each file to be renamed. - -Or to append @file{.old} to all marked files, use @kbd{%r} @samp{$} -@kbd{RET} @samp{.old} @kbd{RET}, replacing the empty string at the end -of each file name with @samp{.old}. - -You can use the regexp @samp{\(.+\)\.\(.+\)$} to make the -basename as @samp{\1} and the extension as @samp{\2} available in -@var{newtext}. - -With a zero prefix arg, renaming by regexp affects the complete -pathname. Usually only the non-directory part of file names is used and -changed, and renaming only takes place within the current directory. -The zero prefix argument can be used to change the directory part as -well. - -Often you will want to apply the command to all files matching the same -@var{regexp} that you use in the command. Simply use the @kbd{%m} -command with @var{regexp} as argument, which will then also be the -default for the next regexp using command.@refill For example, to remove -a @file{V17I12-} prefix from several filenames, use @kbd{%m} -@samp{^V17I12-} @kbd{RET} @kbd{%r} @kbd{RET} @kbd{RET}, in effect -replacing the prefix with the empy string. - -@node Other File Creating Commands, Deleting Files With Dired, Renaming and More With Regexps, Mark-using Commands -@subsection Other File Creating Commands - -@cindex Case-changing Dired commands -@cindex Dired case-changing commands -Commands to change the case of file names: - -@table @kbd -@findex dired-upcase -@kindex %u -@item %u -(@code{dired-upcase}) Rename each marked file to upper case. -@findex dired-downcase -@kindex %l -@item %l -(@code{dired-downcase}) Rename each marked file to lower case. -@end table - -@node Deleting Files With Dired, Dired Shell Commands, Other File Creating Commands, Mark-using Commands -@subsection Deleting Files With Dired - -@noindent -Deleting is a special mark-using command. It uses a special marker, -@samp{D}, and does not default to the current file if no files are -marked to prevent accidental deletions.@refill - -@xref{Dired Customization}, variable @code{dired-del-marker} to make -deleting behave exactly like any mark-using command.@refill - -@table @kbd - -@findex dired-flag-file-deleted -@kindex d -@item d -(@code{dired-flag-file-deleted}) Flag this file for deletion. If on a -subdirectory headerline, mark all its files except @file{.} and @file{..}. - -@findex dired-unmark-subdir-or-file -@kindex u -@item u -(@code{dired-unmark-subdir-or-file}) Remove deletion-flag on this line. - -@findex dired-backup-unflag -@kindex @key{DEL} -@item @key{DEL} -(@code{dired-backup-unflag}) Remove deletion-flag on previous line, -moving point to that line. - -@findex dired-flag-regexp-files -@kindex %d -@item %d -(@code{dired-flag-regexp-files}) Flag all files containing the specified -@var{regexp} for deletion. - -The match is against the non-directory part of the filename. Use -@samp{^} and @samp{$} to anchor matches. Exclude subdirs by hiding -them. - -The special directories @file{.} and @file{..} are never flagged. - -@findex dired-do-deletions -@kindex x -@item x -(@code{dired-do-deletions}) Delete the files that are flagged for -deletion (with @samp{D}). - -@findex dired-do-delete -@kindex X -@item X -(@code{dired-do-delete}) Delete the @samp{*}-marked (as opposed to the -@samp{D}-flagged) files. - -@findex dired-flag-auto-save-files -@kindex # -@item # -(@code{dired-flag-auto-save-files}) Flag all auto-save files (files -whose names start and end with @samp{#}) for deletion (@pxref{Auto -Save,Auto-Saving: Protection Against Disasters,Auto Save,emacs,The GNU Emacs -Manual}). - -@findex dired-flag-backup-files -@kindex ~ -@item ~ -(@code{dired-flag-backup-files}) Flag all backup files (files whose -names end with @samp{~}) for deletion (@pxref{Backup,Backup -Files,Backup,emacs,The GNU Emacs Manual}). - -@findex dired-clean-directory -@kindex . -@item .@: @r{(Period)} -(@code{dired-clean-directory}) Flag excess numeric backup files for -deletion. The oldest and newest few backup files of any one file are -exempt; the middle ones are flagged. -@end table - -You can flag a file for deletion by moving to the line describing the -file and typing @kbd{d} or @kbd{C-d}. The deletion flag is visible as a -@samp{D} at the beginning of the line. Point is moved to the beginning -of the next line, so that repeated @kbd{d} commands flag successive -files. - -The files are flagged for deletion rather than deleted immediately to -avoid the danger of deleting a file accidentally. Until you direct -Dired to delete the flagged files, you can remove deletion flags using -the commands @kbd{u} and @key{DEL}. @kbd{u} works just like @kbd{d}, -but removes flags rather than making flags. @key{DEL} moves upward, -removing flags; it is like @kbd{u} with numeric argument automatically -negated. - -To delete the flagged files, type @kbd{x}. This command first displays -a list of all the file names flagged for deletion, and requests -confirmation with @kbd{yes}. Once you confirm, all the flagged files -are deleted, and their lines are deleted from the text of the Dired -buffer. The shortened Dired buffer remains selected. If you answer -@kbd{no} or quit with @kbd{C-g}, you return immediately to Dired, with -the deletion flags still present and no files actually deleted. - -Deletions proceed from the end of the buffer, so if subdirs are in a -natural order in the buffer, it usually works to flag @samp{dir1}, -@samp{dir1/dir2} and @samp{dir1/dir2/*} (by typing @kbd{d} on the -directory headerlines) and delete everything, including @samp{dir1/dir2} -and @samp{dir1}. Using shell commands (e.g. @samp{rm -rf}) to remove -complete directories may be quicker than having Dired remove each file -separately. (@xref{Dired Shell Commands}.) However, like all actions -external to Dired, this does not update the display.@refill -@c and does not offer to kill buffers of deleted files. - -The @kbd{#}, @kbd{~} and @kbd{.} commands flag many files for deletion, -based on their names. These commands are useful precisely because they -do not actually delete any files; you can remove the deletion flags from -any flagged files that you really wish to keep.@refill - -@kbd{#} flags for deletion all files that appear to have been made by -auto-saving (that is, files whose names begin and end with @samp{#}). -@kbd{~} flags for deletion all files that appear to have been made as -backups for files that were edited (that is, files whose names end with -@samp{~}). - -@vindex dired-kept-versions -@kbd{.} (Period) flags just some of the backup files for deletion: only -numeric backups that are not among the oldest few nor the newest few -backups of any one file. Normally @code{dired-kept-versions} (not -@code{kept-new-versions}; that applies only when saving) specifies the -number of newest versions of each file to keep, and -@code{kept-old-versions} specifies the number of oldest versions to -keep. Period with a positive numeric argument, as in @kbd{C-u 3 .}, -specifies the number of newest versions to keep, overriding -@code{dired-kept-versions}. A negative numeric argument overrides -@code{kept-old-versions}, using minus the value of the argument to -specify the number of oldest versions of each file to keep.@refill - -@node Dired Shell Commands, Compressing and Uncompressing, Deleting Files With Dired, Mark-using Commands -@subsection Shell Commands on Marked files - -@cindex Shell commands (in Dired) -@noindent -You can run arbitrary shell commands on the marked files. If there is -output, it goes to a separate buffer. - -@table @kbd - -@findex dired-do-shell-command -@kindex ! -@item ! -(@code{dired-do-shell-command}) Run a shell command on the marked -files. - -@end table - -A command string is prompted for in the minibuffer. The list of marked -files is appended to the command string unless asterisks @samp{*} -indicate the place(s) where the list should go. Thus,@refill - -@example -command -flags -@end example - -is equivalent to - -@example -command -flags * -@end example - -The filenames are inserted in the order they appear in the buffer. The -file listed topmost in the buffer will be the leftmost in the list. - -Currently, there is no way to insert a real @samp{*} into the command. - -As with all mark-using commands, if no files are marked or a specific -numeric prefix arg is given, the current or the next @var{N} files are -used. The prompt mentions the file(s) or the marker, as appropriate. - -However, for shell commands, a zero argument is special. It means to run -command on each marked file separately: - -@example -cmd * |foo -@end example - -results in - -@example -cmd F1 |foo; @dots{}; cmd F@var{n} |foo -@end example - -Usually - -@example -cmd F1 @dots{} F@var{n} |foo -@end example - -would be executed.@refill - -No automatic redisplay is attempted because Dired cannot know what files -should be redisplayed for a general shell command. For example, a -@samp{tar cvf} will not change the marked files at all, but rather -create a new file, while a @samp{ci -u -m'@dots{}' *} will probably change -the permission bits of all marked files. - -Type @kbd{l} to redisplay just the marked files, or @kbd{l} on a -directory headerline to redisplay just that directory, or @kbd{g} to -redisplay all directories.@refill - -The shell command has the top level directory as working directory, so -output files usually are created there instead of in a subdirectory, -which may sometimes be surprising if all files come from the same -subdirectory. Just remember that an Emacs buffer can have but one -working directory, and this is the top level directory in Dired -buffers. - -Examples for shell commands: - -@itemize @bullet - -@item -Type @kbd{!} and - -@example -tar cvf foo.tar -@end example - -@noindent -to tar all marked files into a @file{foo.tar} file. Dired does not know -that a new file has been created and you have to type @kbd{g} to refresh -the listing. If you have several subdirectories in your Dired buffer, -the names given to @samp{tar} will be relative to the top level -directory, and the output file @file{foo.tar} will also be created -there.@refill - -You can use - -@example -tar cvf - * | compress -c > foo.tar.Z -@end example - -@noindent -as an alternative to immediately compress the tar file. - -@item -Type @kbd{0 !} and - -@example -uudecode -@end example - -@noindent -to uudecode each of the marked files. Note the use of the zero prefix -argument to apply the shell command to each file separately (uudecode -doesn't accept a list of input files). Type @kbd{g} afterwards to see -the created files. - -@item -Type @kbd{0 !} and - -@example -uuencode * * >*.uu -@end example - -@noindent -to uuencode each of the marked files, writing into a corresponding -@file{.uu} file. Note the use of the zero prefix argument to apply the -shell command to each file separately. Type @kbd{g} afterwards to see -the created @file{.uu} files. - -@item -Type @kbd{1 !} and - -@example -mail joe@@somewhere <* -@end example - -@noindent -to mail the current file (note the prefix argument @samp{1}) to user -@samp{joe@@somewhere}.@refill - -@item -@cindex running the current file -@cindex executing the current file -@cindex current file, how to run it -Here is a Dired shell command to execute the current file, assuming no -other files are marked (else just give the prefix @kbd{1} to @kbd{!}): -@example -./* -@end example -which will be expanded to @samp{./@var{cmd}}, thus @var{cmd} will be -executed.. (Just @samp{./} would be expanded to @samp{./ @var{cmd}}, -with an intervening @kbd{SPC}.) This will work even if you don't have -@file{.} in your @code{$PATH}. If @file{.} is in your path (not a good -idea, as you will find out if you dired a directory containing a file -named @file{ls}), a single @kbd{SPC} as command would also work. - -@c <> -@end itemize - -@node Compressing and Uncompressing, Changing File Attributes, Dired Shell Commands, Mark-using Commands -@subsection Compressing and Uncompressing - -@noindent -You can compress or uncompress the marked files. Dired refuses to -compress files ending in @file{.Z} (which are already compressed) or -symbolic links (the link would be overwritten by a plain, compressed -file) and to uncompress files not ending in @file{.Z}. - -@table @kbd - -@findex dired-do-compress -@kindex C -@item C -(@code{dired-do-compress}) Compress the marked files. - -@findex dired-do-uncompress -@kindex U -@item U -(@code{dired-do-uncompress}) Uncompress the marked files. -@end table - -@node Changing File Attributes, Loading and Byte-compiling Emacs Lisp Files, Compressing and Uncompressing, Mark-using Commands -@subsection Changing File Attributes - -@noindent -You can change the file attributes (mode, group, owner) of marked files. - -@table @kbd - -@findex dired-do-chmod -@kindex M -@item M -(@code{dired-do-chmod}) Change the mode (also called ``permission -bits'') of the marked files. This calls the @samp{chmod} program, thus -symbolic modes like @samp{g+w} are allowed. - -Multiple switches like @samp{-fR g+w} are not understood, though. Use -@kbd{!} (@code{dired-do-shell-command}) for that. - -@findex dired-do-chgrp -@kindex G -@item G -(@code{dired-do-chgrp}) Change the group of the marked files. - -@vindex dired-chown-program -@findex dired-do-chown -@kindex O -@item O -(@code{dired-do-chown}) Change the owner of the marked files. This -usually works for the superuser only. It uses the program in the -variable @code{dired-chown-program} to do the change.@refill -@end table - -@node Loading and Byte-compiling Emacs Lisp Files, Printing the Marked Files, Changing File Attributes, Mark-using Commands -@subsection Loading and Byte-compiling Emacs Lisp Files - -@noindent -You can load and byte-compile GNU Emacs Lisp files. Errors are caught and -reported after all files have been processed. - -@table @kbd - -@findex dired-do-load -@kindex L -@item L -(@code{dired-do-load}) Load the marked elisp files. - -@findex dired-do-byte-compile -@kindex B -@item B -(@code{dired-do-byte-compile}) Byte compile the marked elisp files. -@end table - -@node Printing the Marked Files, , Loading and Byte-compiling Emacs Lisp Files, Mark-using Commands -@subsection Printing the Marked Files - -@table @kbd -@findex dired-do-print -@kindex P -@vindex lpr-command -@vindex lpr-switches -@item P -(@code{dired-do-print}) Print the marked (or next @var{N}) files. -Uses the shell command coming from variables @code{lpr-command} and -@code{lpr-switches} as default. - -Since internally this is just a special case of -@code{dired-do-shell-command}, you can use @samp{*} and pipes like for -shell command, e.g., -@example -(setq lpr-command: "lwf") -(setq lpr-switches: '("-l -m * | lpr -Palw")) -@end example -to print with the shell command @samp{lwf -l -m * | lpr -Palw}, where -@samp{*} will be substituted by the marked files. The @code{lpr-buffer} -and @code{lpr-region} don't know about @samp{*} or @samp{|}, though, only -Dired does. -@end table - -@node Commands That Do Not Use Marks, Subdirectories in Dired, Mark-using Commands, Dired -@section Commands That Do Not Use Marks - -@noindent -These are commands that visit files. -@xref{Visiting,Visiting Files,Visiting,emacs,The GNU Emacs Manual}. - -@table @kbd - -@findex dired-advertised-find-file -@kindex f -@item f -(@code{dired-advertised-find-file}) Visits the file described on the -current line. It is just like typing @kbd{C-x C-f} and supplying that -file name. If the file on this line is a subdirectory, @kbd{f} actually -causes Dired to be invoked on that subdirectory. - -@findex dired-find-file-other-window -@kindex o -@item o -(@code{dired-find-file-other-window}) Like @kbd{f}, but uses another -window to display the file's buffer. The Dired buffer remains visible -in the first window. This is like using @kbd{C-x 4 C-f} to visit the -file. @xref{Windows,Multiple Windows,Windows,emacs,The GNU Emacs Manual}. - -@findex dired-view-file -@kindex v -@item v -(@code{dired-view-file}) Views the file described on this line using -@kbd{M-x view-file}. Viewing a file is like visiting it, but is slanted -toward moving around in the file conveniently and does not allow -changing the file. @xref{Misc File Ops,View File,Miscellaneous File -Operations,emacs,The GNU Emacs Manual}. @refill Viewing a file that is a -directory goes to its headerline if it is in this buffer. Otherwise, it -is displayed in another buffer. - -@c Forgot that this only works for my version of C-x C-r... -@c -@c You might think that a @code{dired-view-file-other-window} command is -@c missing, but it is easy to use @kbd{o} followed by @kbd{C-x C-r} -@c @kbd{RET}, which will first visit the file in the other window, then -@c @samp{find-file-read-only} it (@kbd{RET} defaulting to the current -@c buffer's file). - -@end table - -@cindex Diffing files in Dired -@noindent -Commands to diff a file: - -@table @kbd - -@findex dired-diff -@kindex D -@item D -(@code{dired-diff}) Compare file at point with another file (default: -file at mark), by running the system command @samp{diff}. The other -file is the first file given to @samp{diff}. - -@findex dired-backup-diff -@kindex M-~ -@item M-~ -(@code{dired-backup-diff}) Diff this file with its backup file. Uses -the latest backup, if there are several numerical backups. If this file -is a backup, diff it with its original. The backup file is the first -file given to @samp{diff}. -@end table - -@noindent -Other commands: - -@table @kbd -@findex dired-create-directory -@kindex + -@cindex Creating a directory in Dired -@cindex Directory, how to create one in Dired -@item + -(@code{dired-create-directory}) Create a directory. -@end table - -@table @kbd -@findex dired-why -@kindex W -@cindex Why something went wrong in Dired -@cindex Error logging in Dired -@item W -(@code{dired-why}) Pop up a buffer with error log output from Dired. -All mark-using commands log errors there. (Standard error from shell -commands cannot be logged separately, it goes into the usual shell -command output buffer.) A group of errors from a single command ends -with a formfeed, so that you can use @kbd{C-x [} (@code{backward-page}) -to find the beginning of new error logs that are reported by a command. - -@end table - -@node Subdirectories in Dired, Hiding Directories in Dired, Commands That Do Not Use Marks, Dired -@section Subdirectories in Dired - -@noindent -Thise section explains how to @dfn{insert} (or @dfn{expand}) -subdirectories in the same Dired buffer and move around in them. -@cindex Inserting subdirectories in same Dired buffer -@cindex Expanding subdirectories in Dired - -You can display subdirectories in your Dired buffer by using @samp{-R} -in your Dired listing switches. But you do not usually want to have a -complete recursive listing in all your Dired buffers. So there is a -command to insert a single directory: - -@table @kbd - -@findex dired-maybe-insert-subdir -@kindex i -@item i -@cindex Inserted subdirectory -@cindex Expanded subdirectory -@cindex In-situ subdirectory -@cindex Headerline -(@code{dired-maybe-insert-subdir}) Insert this subdirectory into the -same Dired buffer. If it is already present, just move to it (type -@kbd{l}, @code{dired-do-redisplay} to refresh it). Else inserts it as -@samp{ls -lR} would have done. With a prefix arg, you may edit the ls -switches used for this listing. You can add @samp{R} to the switches to -expand the whole tree starting at this subdirectory. This function -takes some pains to conform to @samp{ls -lR} output. For example, it adds the -headerline for the inserted subdirectory.@refill - -The mark is dropped before moving, so @kbd{C-x C-x} takes you back to -the old position in the buffer. - -@end table - -Dired changes the buffer-local value of the variable -@code{page-delimiter} to @code{"\n\n"}, so that subdirectories become -pages. Thus, the page moving commands @kbd{C-x [} and @kbd{C-x ]} -(@code{backward-page} and @code{forward-page}) can be used to move to -the beginning (i.e., the headerlines) of subdirectories. - -In addition, the following commands move around directory-wise, usually -putting you on a file line instead of on a headerline. For a mnemonic, -note that they all look like rotated versions of each other, and that -they move in the direction they point to. - -@table @kbd - -@findex dired-prev-dirline -@kindex < -@item < -(@code{dired-prev-dirline}) Goto previous directory file line. - -@findex dired-next-dirline -@kindex > -@item > -(@code{dired-next-dirline}) Goto next directory file line. - -@findex dired-up-directory -@kindex ^ -@item ^ -(@code{dired-up-directory}) Dired parent directory. Tries first to find -its file line, then its header line in this buffer, then its Dired -buffer, finally creating a new Dired buffer if necessary. - -@findex dired-view-file -@kindex v -@item v -(@code{dired-view-file}) When the current file is not a directory, view -it. When file is a directory, tries to go to its subdirectory. - -@comment actually, it is not always inverse -This command is inverse to the @kbd{^} command and it is very convenient -to use these two commands together. - -@end table - -The following commands move up and down in the directory tree: - -@table @kbd - -@findex dired-tree-up -@kindex M-C-u -@item M-C-u -(@code{dired-tree-up}) Go up to the parent directory's headerline. - -@findex dired-tree-down -@kindex M-C-d -@item M-C-d -(@code{dired-tree-down}) Go down in the tree, to the first -subdirectory's headerline. - -@end table - -The following commands move forwards and backwards to subdirectory headerlines: - -@table @kbd - -@findex dired-next-subdir -@kindex M-C-n -@item M-C-n -(@code{dired-next-subdir}) Go to next subdirectory headerline, -regardless of level. - -@findex dired-prev-subdir -@kindex M-C-p -@item M-C-p -(@code{dired-prev-subdir}) Go to previous subdirectory headerline, -regardless of level. - -@end table - -@node Hiding Directories in Dired, Acknowledgement, Subdirectories in Dired, Dired -@section Hiding Directories in Dired - -@cindex Hiding in Dired -@noindent -@dfn{Hiding} a subdirectory means to make it invisible, except for its -headerline. Files inside a hidden subdirectory are never considered by -Dired. For example, mark-using commands will not ``see'' files in a -hidden directory. Thus you can use hiding to temporarily exclude -subdirectories from operations without having to remove the markers. - -The hiding commands toggle, that is they unhide what was hidden and vice -versa. - -@table @kbd - -@findex dired-hide-subdir -@kindex $ -@item $ -(@code{dired-hide-subdir}) Hide or unhide the current subdirectory and -move to next directory. Optional prefix argument is a repeat factor. - -@findex dired-hide-all -@kindex = -@item = -(@code{dired-hide-all}) Hide all subdirectories, leaving only their -header lines. If there is already something hidden, make everything -visible again. Use this command to get an overview in very deep -directory trees or to move quickly to subdirs far away. -@end table - -@node Acknowledgement, Dired Customization, Hiding Directories in Dired, Dired -@section Acknowledgement - -@noindent -I would like to thank - -@itemize @bullet -@item -Richard Stallman for providing a pre-release version of @file{dired.el} -from Emacs 19, critical comments and many helpful suggestions -@item -Andy Norman for the collaboration that made Tree Dired and ange-ftp such -a successful combination -@item -Jamie Zawinski for insisting on and writing nested Dired format, and for -lots of other things -@item -Michael Ernst for the ``omitting'' code and helpful discussion about -Dired design -@item -Hans Chalupsky for providing FTP service and writing -@file{dired-trns.el} -@item -Roland McGrath for @file{find-dired.el} and bug fixes for the diffing -commands -@item -Kevin Gallagher for sending me existing VMS Dired fixes -@item -Hal R. Brand for VMS support and porting his old dired fixes to Tree -Dired -@item -Hugh Secker-Walker for writing @file{dired-cd.el} -@item -Tom Wurgler for ideas such as the @dfn{dired-jump-back} command -@item -Cengiz Alaettinoglu, who found more bugs in Tree Dired than anybody else -(except me) -@end itemize -@noindent -and all other beta testers and people who reported bugs or just said -``thanks''. - -@node Dired Customization, , Acknowledgement, Dired -@section Dired Customization - -@noindent -You can customize Dired by setting some variables in your @file{~/.emacs} -file. Other variables are intended to be configured when Dired is -installed. Finally, there are so-called `hook' variables. - -@menu -* Dired User Options:: -* Dired Configuration:: -* Dired Hooks:: -@end menu - -@node Dired User Options, Dired Configuration, Dired Customization, Dired Customization -@subsection Customization of Dired - -@noindent -The following variables are for personal customization in your -@file{~/.emacs} file. For example, include a line similar to the -following - -@example -(setq dired-listing-switches "-Alt") ; sort on time, ignore . and .. -@end example - -to set your favorite Dired listing switches. - -@c Should actually use @defopt here, but this is in Texinfo2 only. - -@table @code - -@vindex dired-listing-switches -@item dired-listing-switches - -Default: @code{"-al"} - -Switches passed to @samp{ls} for Dired. @i{Must} contain the @samp{l} option. - -@vindex dired-trivial-filenames -@item dired-trivial-filenames - -Default: @code{"^\\.\\.?$\\|^#"} - -Regexp of files to skip when moving point to the first file of a new -directory listing. Nil means move to the subdirectory line, t means move to -first file. - -@vindex dired-marker-char -@item dired-marker-char - -Default: @code{?*} (@samp{?*} is the Lisp notation for the character -@samp{*}.) - -In Dired, character used to mark files for later commands. - -This is a variable so that one can write things like - -@example -(let ((dired-marker-char ?X)) - ;; great code using X markers ... - ) -@end example - -@vindex dired-del-marker -@item dired-del-marker - -Default: @code{?D} - -Character used to flag files for deletion. - -Usually, marking for commands and flagging for deletion are separate -features. (Internally they use the same marking mechanism.) You type -@kbd{d} to flag with @samp{D} and @kbd{x} to delete the @samp{D}-flagged -files.@refill - -This explains how to make deletion behave just like a special case of -the general file marking feature, so that you type @kbd{m} to mark with -@samp{*} (as usual) and @kbd{d} to delete the @samp{*} (or next @var{N}) -files: In your @file{~/.emacs}, include - -@example -(setq dired-del-marker dired-marker-char) ; use * also for deletions -(setq dired-load-hook - (function - (lambda () - ;; other customizations here - ;; let "d" do the actual deletion: - (define-key dired-mode-map "d" 'dired-do-delete)))) -@end example - -If you do not like that @kbd{d} defaults to the current file if there -are no marks, replace the @code{define-key} statement in -@code{dired-load-hook} above with this one: - -@example - (define-key dired-mode-map "d" 'dired-do-deletions) -@end example - -@vindex dired-shrink-to-fit -@item dired-shrink-to-fit - -Default: @code{(if (fboundp 'baud-rate) (> (baud-rate) search-slow-speed) t)} - -Whether Dired shrinks the display buffer to fit the marked files. - -@vindex dired-no-confirm -@item dired-no-confirm - -Default: @code{nil} - -If non-nil, list of commands Dired should not confirm. Confirmation for -commands that require an argument to be entered (like the shell command -for @kbd{!}) means a list of marked files is displayed in a pop-up -buffer. Confirmation for commands that do not require an argument (like -compressing with @kbd{C}) means you have to confirm by typing @kbd{y} or -@kbd{SPC}. - -Except @code{nil}, it can be a sublist of - -@example -'(byte-compile chgrp chmod chown compress copy delete hardlink load - move print shell symlink uncompress) -@end example - -to suppress confirmation for just those commands. - -@c @vindex dired-deletion-confirmer -@c But you can -@c set the variable @code{dired-deletion-confirmer} to another function -@c than @code{yes-or-no-p}, its default value. Using @code{y-or-no-p} will -@c confirm with only a single key stroke, @key{y} or @key{n}, and using -@c @code{identity} will effectively switch off confirmation. - -@vindex dired-keep-marker-move -@item dired-keep-marker-move - -Default: @code{t} - -If nil, moved files are not marked. - -If t, moved marked files are marked with the same marker they had before -(maybe none if you used the prefix argument to specify the next @var{N} -files). - -If a character, moved files (marked or not) are marked with that -character. - -This also applies to the following, similar variables for copied, and -hard or symbolically linked files: - -@vindex dired-keep-marker-copy -@item dired-keep-marker-copy - -Default: @code{?C} - -@vindex dired-keep-marker-hardlink -@item dired-keep-marker-hardlink - -Default: @code{?H} - -@vindex dired-keep-marker-symlink -@item dired-keep-marker-symlink - -Default: @code{?Y} - -@vindex dired-dwim-target -@item dired-dwim-target - -Default: @code{nil} - -If non-nil, Dired tries to guess a default target directory: If there is -a Dired buffer displayed in the next window, use its current subdirectory, -instead of the current subdirectory of this Dired buffer. - -The target is used in the prompt for file copy, move etc., -@xref{Copy and Move Into a Directory}. - -@item dired-copy-preserve-time -@vindex dired-copy-preserve-time - -Default: @code{nil} - -If non-nil, Dired preserves the last-modified time in a file copy. -(This works on only some systems.) Use @kbd{c} (@code{dired-do-copy}) -with a zero prefix argument to toggle its value. The prompt of copy -commands will display @samp{Copy [-p]} instead of just @samp{Copy} if -preservation of file times is turned on. - -@item dired-backup-if-overwrite -@vindex dired-backup-if-overwrite - -Default: @code{nil} - -Non-nil if Dired should ask about making backups before overwriting files. -Special value @code{'always} suppresses confirmation. - -@end table - -@node Dired Configuration, Dired Hooks, Dired User Options, Dired Customization -@subsection Dired Configuration - -The following variables should have already been installed correctly by -your system manager. If not, you can still set them in your -@file{~/.emacs} file.@refill - -@table @code - -@vindex dired-chown-program -@item dired-chown-program -Pathname of chown command, default @code{"chown"} (or -@code{"/etc/chown"} on System V derived systems.) - -@vindex dired-ls-program -@item dired-ls-program -Absolute or relative name of the @samp{ls} program used by Dired, -default @code{"ls"}. - -@vindex dired-ls-F-marks-symlinks -@item dired-ls-F-marks-symlinks -Set this to @code{t} if dired-ls-program with @samp{-lF} marks the -symbolic link itself with a trailing @samp{@@} (usually the case under -Ultrix). - -Example: If - -@example -ln -s foo bar; ls -F bar -@end example - -gives - -@example -bar -> foo -@end example - -set it to @code{nil}, if it gives - -@example -bar@@ -> foo -@end example - -set it to @code{t}. - -Dired checks if there is really a @@ appended. Thus, if you have a -marking @samp{ls} program on one host and a non-marking one on another -host, and do not care about symbolic links which really end in a @@, you -can always set this variable to @code{t}. - -@end table - - -@node Dired Hooks, , Dired Configuration, Dired Customization -@subsection Dired Hooks - -@noindent -Hook variables can contain functions that are run at certain times in -Dired. - -@table @code - -@vindex dired-load-hook -@item dired-load-hook - -Run after loading Dired. You can customize key bindings or load -extensions with this. For example: - -@example -(setq dired-load-hook - (function - (lambda () - ;; Load extras: - (load "dired-x") - ;; How to define your own key bindings: - (define-key dired-mode-map " " 'scroll-up) - (define-key dired-mode-map "b" 'scroll-down)))) -@end example - -@vindex dired-mode-hook -@item dired-mode-hook - -Run at the very end of @code{dired-mode}, after most buffer local -variables have been initialized (e.g., @code{default-directory} and -@code{dired-directory}), but before the directory listing has been read -in. - -Do buffer local things here, for example: - -@example -(setq dired-mode-hook - (function - (lambda () - (dired-extra-startup) ;; dired-extra support - ;; How to set (local) variables in each new Dired buffer: - (setq case-fold-search t) - (setq truncate-lines t)))) -@end example - -Since the listing has not yet been inserted you could still change -@code{dired-actual-switches}. For example, if you use -@file{ange-ftp.el}, you might want to replace the @samp{-A} with the -@samp{-a} switch, depending on whether @code{default-directory} -corresponds to a System V hosts that does not understand all BSD -@samp{ls} switches. The @code{dired.README} file gives an example. If -you set @code{dired-actual-switches} remember that you may also have to -set @code{dired-sort-mode} to the appropriate string so that the -modeline looks right. - -Do not set @code{dired-mode-hook} inside your @code{dired-load-hook}, -simply set it somewhere in your @file{~/.emacs} (before Dired is loaded, -if you explicitly load Dired). This is so that extensions packages -loaded via the load hook can add things to the @code{dired-mode-hook} at -the front or at the end, as they see fit. - -In case you set @code{truncate-lines} to @code{t} as in the above -example, here is a function to toggle the value of -@code{truncate-lines}, in Dired and other buffers: -@example -(defun set-truncate-lines () - "Toggle value of truncate-lines and refresh window display." - (interactive) - (setq truncate-lines (not truncate-lines)) - ;; now refresh window display (an idiom from simple.el): - (save-excursion - (set-window-start (selected-window) - (window-start (selected-window))))) -@end example -You could bind it to @kbd{C-x 4 $}: -@example -(define-key ctl-x-4-map "$" 'set-truncate-lines) -@end example -It is sometimes useful to toggle @code{truncate-lines} in Dired buffers -to make long filenames completely visible and get the listing properly -aligned again. - -@vindex dired-before-readin-hook -@item dired-before-readin-hook -This hook is run before a dired buffer is newly read in (created or reverted). - -@vindex dired-after-readin-hook -@item dired-after-readin-hook - -After each listing of a file or directory, this hook is run with the -buffer narrowed to the listing. - -The @code{dired-subdir-alist} has already been updated so that the usual -Dired functions like @code{dired-get-filename} work. It is possible to -modify the buffer with this hook. The package @file{dired-x.el} does -this to implement omitting certain uninteresting files from a Dired -buffer. Under X11, highlighting of certain files is also possible (see -package @file{dired-x11.el}). - -@end table - -@node Tree Dired Extra, Dired Internals, Dired, Top -@chapter Tree Dired Extra features - -Numerous ``extra'' features are available, such as omitting certain -files from listings, minibuffer history, RCS related commands, and more. - -@menu -* Tree Dired Extra Features:: -* Dired Minibuffer History:: -* Inserting All Marked Subdirectories:: -* Dynamic Dired Markers:: -* Omitting Files in Dired:: -* Advanced Dired Mark Commands:: -* Virtual Dired:: -* Multiple Dired Directories:: -* Dired Local Variables:: -* Making Relative Symbolic Links in Dired:: -* Letting Dired Guess What Shell Command to Apply:: -* dired-trns.el:: Filename Transformers for Dired Shell Commands -* dired-cd.el:: Changing the Working Directory for Dired Shell Commands -* dired-nstd.el:: Nested Dired format -* find-dired.el:: Feeding Find Output to Dired -@end menu - -@node Tree Dired Extra Features, Dired Minibuffer History, Tree Dired Extra, Tree Dired Extra -@section Tree Dired Extra Features - -The rest of this manual describes the extra features provided by the -file @file{dired-x.el} and some other files. - -To take advantage of these features, you must load the file and set some -variables and hooks. See the accompanying @file{dired-x.README} -file for details and a template of code to insert in your @file{.emacs}. - -Miscellanous features not fitting anywhere else: - -Variables: - -@table @code - -@item dired-find-subdir -@vindex dired-find-subdir -Default: @code{nil} - -If non-nil, Dired does not make a new buffer for a directory if it -can be found (perhaps as subdirectory) in some existing Dired buffer. - -If there are several Dired buffers for a directory, the most recently -used is chosen. - -Dired avoids switching to the current buffer, so that if you have a -normal and a wildcard buffer for the same directory, @kbd{C-x d RET} -will toggle between those two. - -@end table - -@table @kbd - -@findex dired-goto-file -@kindex M-g -@item M-g -(@code{dired-goto-file}) Goto file line of a file (or directory). - -@findex dired-goto-subdir -@kindex M-G -@item M-G -(@code{dired-goto-subdir}) Goto headerline of an inserted directory. -This commands reads its argument with completion over the names of the -inserted subdirectories. -@end table - -@table @kbd - -@findex dired-do-background-shell-command -@kindex & -@cindex Input to Dired shell commands -@cindex Interactive Dired shell commands -@cindex Background Dired shell commands -@item & -(@code{dired-do-background-shell-command}) Run a shell command on the -marked files, in the background. This requires @file{background.el} -from Olin Shiver's comint package to work. Note that you can type input -to the command in its buffer. - -@item w -@kindex w -@findex dired-copy-filename-as-kill -(@code{dired-copy-filename-as-kill}) The @kbd{w} command puts the names -of the marked (or next @var{N}) files into the kill ring, as if you had -killed them with @kbd{C-w}. With a zero prefix argument @var{N}=0, use the -complete pathname of each file. With a raw (just @kbd{C-u}) prefix argument, -use the relative pathname of each marked file. As a special case, if no -prefix argument is given and point is on a directory headerline, it -gives you the name of that directory, without looking for marked files. - -@vindex dired-marked-files -The list of names is also stored onto the variable @code{dired-marked-files} -for use, e.g., in an @kbd{ESC ESC} (@code{eval-expression}) command. - -As this command also displays what was pushed onto the kill ring you can -use it to display the list of currently marked files in the -echo area (unless you happen to be on a subdirectory headerline). - -You can then feed the file name to other Emacs commands with @kbd{C-y}. -For example, say you want to rename a long filename to a slightly -different name. First type @kbd{w} to push the old name onto the kill -ring. Then type @kbd{r} to rename it and use @kbd{C-y} inside @kbd{r}'s -minibuffer prompt to insert the old name at a convenient place. - -@item T -@kindex T -@findex dired-do-toggle -(@code{dired-do-toggle}) Toggle marks. That is, currently marked -files become unmarked and vice versa. Files marked with other flags -(such as `D') are not affected. The special directories `.' and `..' -are never toggled. - -@end table - -@node Dired Minibuffer History, Inserting All Marked Subdirectories, Tree Dired Extra Features, Tree Dired Extra -@section Minibuffer History for Dired Shell Commands - -@cindex History of Minibuffer input -@cindex Minibuffer History -@cindex Gmhist -@kindex ! -@kindex & -@kindex M-p -@kindex M-n -If @file{dired-x.el} determines at load-time that the Gmhist package is -available, the Dired shell commands @kbd{!} and @kbd{&} maintain a -history of commands. Use @kbd{M-p} and @kbd{M-n} to scroll through them -while you are prompted in the minibuffer for a shell command. -@xref{Gmhist Keys in the Minibuffer,Gmhist Keys in the Minibuffer,Gmhist -Keys in the Minibuffer,gmhist,The Gmhist Manual}, for more info. - -Gmhist also handles defaults: - -@table @code - -@vindex dired-dangerous-shell-command -@item dired-dangerous-shell-command -Default: @code{"rm"} - -Regexp for dangerous shell commands that should never be the default. -It is deliberately chosen to match @samp{rm} anywhere in the command, -e.g. in @samp{rmdir}. -@end table - -@node Inserting All Marked Subdirectories, Dynamic Dired Markers, Dired Minibuffer History, Tree Dired Extra -@section Insert all marked subdirectories - -@table @kbd - -@kindex I -@findex dired-do-insert-subdir -@item I -(@code{dired-do-insert-subdir}) Insert all marked subdirectories that -are not already inserted. Non-directories are silently ignored. - -Thus type @kbd{/I} to insert one more level of subdirectories. You can -repeat this until no new directories are inserted to fully expand the -directory tree in this buffer. As a faster alternative, use the prefix -argument for @kbd{C-x d} (@code{dired}) to add @samp{R} to the switches. - -@end table - -@node Dynamic Dired Markers, Omitting Files in Dired, Inserting All Marked Subdirectories, Tree Dired Extra -@section Dynamic Marker Characters - -@cindex Dynamic marker characters -@cindex Marker characters in Dired, changing them -@cindex Changing marker character in Dired -@cindex Stack of marker characters in Dired -You can change the marker character from its usual value @code{*} to -something else. Use this to mark a different set of files while keeping -the information on the already marked files. You can nest several -marker characters. The current stack of marker characters is displayed -in the Dired mode line, and all prompts of mark-using commands mention -to which marker they apply. - -@table @kbd - -@item ( -@kindex ( -@findex dired-set-marker-char -(@code{dired-set-marker-char}) Set the marker character to something -else. Use @kbd{)} to restore the previous value. - -@item ) -@kindex ) -@findex dired-restore-marker-char -(@code{dired-restore-marker-char}) Restore the marker character to its -previous value. Uses @code{dired-default-marker} if the marker stack is -empty. -@end table - -@kindex A -@kindex Z -@kindex m -@kindex ( -Instead of using @kbd{m} inside a @kbd{(}@dots{}@kbd{)}, you can mark -files ``in passing'' with, say @samp{Z} without changing the -current marker character. You will probably later use @kbd{(} to -temporarily make @samp{Z} to the marker and do something on the -@samp{Z}-files, and then return using @code{)}. - -@table @code - -@item dired-mark-keys -Default: @code{'("Z")} - -List of keys (strings) that insert themselves as file markers. - -@end table - - -@node Omitting Files in Dired, Advanced Dired Mark Commands, Dynamic Dired Markers, Tree Dired Extra -@section Omitting Files in Dired - -@cindex Omitting Files in Dired -@dfn{Omitting} a file means removing it from the directory listing. -Omitting is useful for keeping Dired buffers free of uninteresting files -(for instance, auto-save, auxiliary, backup, and revision control files) -so that the user can concentrate on the interesting files. Like hidden -files, omitted files are never seen by Dired. -@xref{Dired Hiding,Hiding in Dired,Hiding in Dired,dired,Tree Dired Manual}. -Omitting differs from hiding in several respects: - -@itemize @bullet - -@item -Omitting works on individual files, not on directories; an entire -directory cannot be omitted (though each of its files could be). - -@item -Omitting is wholesale; if omitting is turned on for a dired buffer, then -all ``uninteresting'' files listed in that buffer are omitted. The user -does not omit (or unomit) files one at a time. - -@item -Omitting can be automatic; uninteresting file lines in the buffer can -be removed before the user ever sees them. - -@item -Marked files are never omitted. -@end itemize - -@table @kbd - -@item M-o -@kindex M-o -@findex dired-omit-toggle -(@code{dired-omit-toggle}) -Toggle between displaying and omitting ``uninteresting'' files. -With a prefix argument, don't toggle and just mark the files, but don't -actually omit them. -@end table - -In order to make omitting work, you must have @code{dired-omit-expunge} -on your @code{dired-after-readin-hook}, and you must call -@code{dired-omit-startup} (or @code{dired-extra-startup}, which calls -@code{dired-omit-startup}) in your @code{dired-mode-hook}. Simply -loading @file{dired-x.el} inside @code{dired-load-hook} takes care of -all this. - -The following variables can be used to customize omitting. - -@table @code - -@vindex dired-omit-files-p -@item dired-omit-files-p - -Default: @code{nil} - -@cindex How to make omitting the default in Dired -If non-nil, ``uninteresting'' files are not listed. Uninteresting files -are those whose filenames match regexp @code{dired-omit-files}, plus those -ending with extensions in @code{dired-omit-extensions}. @kbd{M-o} -(@code{dired-omit-toggle}) toggles its value, which is buffer-local. Do - -@example -(setq dired-omit-files-p t) -@end example - -inside your @code{dired-mode-hook} to have omitting initially turned on -in every Dired buffer. Since @file{dired-x.el} prepends the form -@samp{(dired-extra-startup)} to what you put yourself in your -@code{dired-mode-hook}, the @code{setq} will take place after -@code{dired-omit-files-p} has already been made local to the current -Dired buffer, so modelines of non-dired buffers are not affected. For -this to work you shouldn't set @code{dired-mode-hook} inside -@code{dired-load-hook}, but directly in your @file{~/.emacs} (before -Dired is loaded, if you explicitly load Dired). - -You can then use @kbd{M-o} to unomit in that buffer. - -@vindex dired-omit-files -@item dired-omit-files - -Default: @code{"^#\\|\\.$"} - -Filenames matching this buffer-local regexp will not be displayed. -This only has effect when @code{dired-omit-files-p} is t. - -The default value omits the special directories @file{.} and @file{..} -and autosave files (plus other files ending in ``.''). - -@vindex dired-omit-extensions -@item dired-omit-extensions - -Default: The elements of @code{completion-ignored-extensions}, -@code{latex-unclean-extensions}, @code{bibtex-unclean-extensions} and -@code{texinfo-unclean-extensions}. - -If non-nil, a list of extensions (strings) to omit from Dired listings. -Its format is the same as that of @code{completion-ignored-extensions}. - -@vindex dired-omit-localp -@item dired-omit-localp - -Default: @code{'no-dir} - -The @var{localp} argument @code{dired-omit-expunge} passes to -@code{dired-get-filename}. If it is @code{'no-dir}, omitting is much -faster, but you can only match against the non-directory part of the -filename. Set it to @code{nil} if you need to match the whole pathname -or @code{t} to match the pathname relative to the buffer's top-level -directory. - -@item dired-omit-marker-char -@vindex dired-omit-marker-char - -Default: @kbd{C-o} - -Temporary marker used by Dired to implement omitting. -Should never be used as marker by the user or other packages. -@cindex Omitting additional files -There is one exception to this rule: by doing -@example -(setq dired-mark-keys "\C-o") -;; i.e., the value of dired-omit-marker-char -;; (which is not defined yet) -@end example -anywhere in your @file{~/.emacs}, you will bind the @kbd{C-o} key to -insert a @key{C-o} marker, thus causing these files to be omitted in -addition to the usually omitted files. Unfortunately the files you -omitted manually this way will show up again after reverting the buffer, -unlike the others. - -@end table - -@cindex RCS files, how to omit them in Dired -@cindex Omitting RCS files in Dired -To avoid seeing RCS files and the RCS directory, do -@example -(setq dired-omit-files "\\.$\\|#\\|^RCS$\\|,v$") -@end example -This assumes @code{dired-omit-localp} has its default value of -@code{'no-dir} to make the @code{^}-anchored matches work. As a slower -alternative, with @code{dired-omit-localp} set to @code{nil}, you can -use @code{/} instead of @code{^} in the regexp. - -@cindex Tib files, how to omit them in Dired -@cindex Omitting tib files in Dired -If you use tib, the bibliography program for use with @TeX{} and -La@TeX{}, you might want to omit the @file{INDEX} and the @file{-t.tex} -files: -@example -(setq dired-omit-files "\\.$\\|#\\|^INDEX$\\|-t\\.tex$") -@end example - -@node Advanced Dired Mark Commands, Virtual Dired, Omitting Files in Dired, Tree Dired Extra -@section Advanced Mark Commands - -@table @kbd - -@item M-( -@kindex M-( -@findex dired-mark-sexp -@cindex Lisp expression, marking files with in Dired -@cindex Mark file by lisp expression -(@code{dired-mark-sexp}) Mark files for which @var{predicate} returns non-nil. -With a prefix argument, unflag those files instead. - -The @var{predicate} is a lisp expression that can refer to the following -symbols: -@table @code -@item inode -[@i{integer}] the inode of the file (only for @samp{ls -i} output) -@item s -[@i{integer}] the size of the file for @samp{ls -s} output (usually in blocks or, -with @samp{-k}, in KBytes) -@item mode -[@i{string}] file permission bits, e.g., @samp{"-rw-r--r--"} -@item nlink -[@i{integer}] number of links to file -@item uid -[@i{string}] owner -@item gid -[@i{string}] group (If the gid is not displayed by @samp{ls}, this -will still be set (to the same as uid)) -@item size -[@i{integer}] file size in bytes -@item time -[@i{string}] the time that @samp{ls} displays, e.g., @samp{"Feb 12 14:17"} -@item name -[@i{string}] the name of the file -@item sym -[@i{string}] if file is a symbolic link, the linked-to name, else @samp{""} -@end table - -@noindent -For example, use -@example -(equal 0 size) -@end example -to mark all zero length files. - -To find out all not yet compiled Emacs lisp files in a directory, dired -all @file{.el} files in the lisp directory using the wildcard -@samp{*.el}. Then use @kbd{M-(} with -@example -(not (file-exists-p (concat name "c"))) -@end example -to mark all @file{.el} files without a corresponding @file{.elc} file. - -@item M-M -@kindex M-M -@cindex Marker character, how to replace it -@cindex Replacing one marker character with another -(@code{dired-do-unmark}) Unmark marked files by replacing the marker -with another character. The new character defaults to a space, -effectively unmarking them. - -@item , -@kindex , -@cindex RCS controlled files, how to mark them -@cindex Marking RCS controlled files -(@code{dired-mark-rcs-files}) Mark all files that are under RCS control. -With prefix argument, unflag all those files. Mentions RCS files for -which a working file was not found in this buffer. Type @kbd{W} -(@code{dired-why}) to see them again. - -@item C-m C-c -@kindex C-m C-c -@cindex Compilation files, how to mark them -@cindex Marking compilation files -@cindex List of files, how to mark them -@cindex Marking a list of files from a buffer -(@kbd{C-m C-c} is the suggested binding for -@code{dired-mark-files-compilation-buffer}, it is not bound by default.) -Mark the files mentioned in the @samp{*compilation*} buffer. With an -argument, you may specify the other buffer and your own regexp instead of -@code{compilation-error-regexp}. Use @samp{^.+$} (the default with a -prefix argument) to match complete lines. In conjunction with narrowing the -other buffer you can mark an arbitrary list of files, one per line, with -this command. If your regexp contains a subexpression, i.e. -@samp{\(@var{...}\)}, that subexpression is taken for the file name, -else the whole match is used. Thus you can easily strip pre- and -suffixes from filenames by using @samp{@var{prefix}\(.+\)@var{postfix}} -as regexp. - -This is especially useful for a list of files obtained from @kbd{M-x -grep} or output from a similar shell command. - -@item C-m C-d -@kindex C-m C-d -@cindex Corresponding files, how to mark them -@cindex List of files, how to mark them -(@kbd{C-m C-d} is the suggested binding for -@code{dired-mark-files-from-other-dired-buffer}, it is not bound by default.) -Mark those files in this Dired buffer that have the same name as the -marked files in the Dired buffer in the other window. - -In short, mark the corresponding files from the other Dired buffer. - -@end table - -@table @kbd -@item F -@kindex F -@cindex Visiting several files at once -@cindex Simultaneous visiting of several files -@findex dired-do-find-file -(@code{dired-do-find-file}) Visit all marked files at once, and -display them simultaneously. If you want to keep the dired buffer -displayed, type @kbd{C-x 2} first. If you want just the marked files -displayed and nothing else, type @kbd{C-x 1} first. - -The current window is split across all files. Remaining lines go to the -last window. - -The number of files that can be displayed this way is restricted by the -height of the current window and the variable @code{window-min-height}. - -@end table - -@table @code - -@item dired-mark-extension -@findex dired-mark-extension -Mark all files with a certain extension for use in later commands. -A @samp{.} is not automatically prepended to the string entered. - -When called from lisp, @var{extension} may also be a list of extensions -and an optional argument @var{marker-char} specifies the marker used. - -@item dired-flag-extension -@findex dired-flag-extension -Flag all files with a certain extension for deletion. -A @samp{.} is @emph{not} automatically prepended to the string entered. - -@item dired-clean-patch -@findex dired-clean-patch -Flag dispensable files created by the @samp{patch} program for deletion. -See variable @code{patch-unclean-extensions}. - -@item dired-clean-tex -@findex dired-clean-tex -Flag dispensable files created by @TeX{}, La@TeX{} and @samp{texinfo} -for deletion. See variables @code{tex-unclean-extensions}, -@code{texinfo-unclean-extensions}, @code{latex-unclean-extensions} and -@code{bibtex-unclean-extensions}. - -@end table - -Variables used by the above cleanup commands (and in the default value -for variable @code{dired-omit-extensions}): - -@table @code - -@item patch-unclean-extensions -@vindex patch-unclean-extensions -Default: @code{'(".rej" ".orig")} - -List of extensions of dispensable files created by the @samp{patch} program. - -@item tex-unclean-extensions -@vindex tex-unclean-extensions -Default: @code{'(".toc" ".log" ".aux")} - -List of extensions of dispensable files created by @TeX{}. - -@item texinfo-unclean-extensions -@vindex texinfo-unclean-extensions -Default: @code{'(".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" -".tp" ".tps" ".vr" ".vrs")} - -List of extensions of dispensable files created by texinfo. - -@item latex-unclean-extensions -@vindex latex-unclean-extensions -Default: @code{'(".idx" ".lof" ".lot" ".glo")} - -List of extensions of dispensable files created by LaTeX. - -@item bibtex-unclean-extensions -@vindex bibtex-unclean-extensions -Default: @code{'(".blg" ".bbl")} - -List of extensions of dispensable files created by BibTeX. - -@end table - - -@node Virtual Dired, Multiple Dired Directories, Advanced Dired Mark Commands, Tree Dired Extra -@section Virtual Dired - -@cindex Virtual Dired -@cindex Perusing ls listings -@cindex ls listings, how to peruse them in Dired -Using @dfn{Virtual Dired} means putting a buffer with Dired-like -contents in Dired mode. The files described by the buffer contents need -not actually exist. This is useful if you want to peruse an @samp{ls -lR} -output file, for example one you got from an FTP server. You can use -all motion commands usually available in Tree Dired. You can also use -it to save a Dired buffer in a file and resume it in a later session. - -@findex dired-virtual -@kindex g -@findex dired-virtual-revert -Type @kbd{M-x dired-virtual} to put the current buffer into virtual -Dired mode. You will be prompted for the top level directory of this -buffer, with a default value guessed from the buffer contents. To -convert the virtual to a real Dired buffer again, type @kbd{g} (which -calls @code{dired-virtual-revert}) in the virtual Dired buffer and -answer @samp{y}. You don't have to do this, though: you can relist -single subdirectories using @kbd{l} (@code{dired-do-redisplay}) on the subdirectory -headerline, leaving the buffer in virtual Dired mode all the time. - -@findex dired-virtual-mode -@vindex auto-mode-alist -The function @samp{dired-virtual-mode} is specially designed to turn on -virtual Dired mode from the @code{auto-mode-alist}. To automatically -edit all @file{*.dired} files in virtual Dired mode, put this into your -@file{~/.emacs}: - -@example -(setq auto-mode-alist (cons '("[^/]\\.dired$" . dired-virtual-mode) - auto-mode-alist)) -@end example - -The regexp is a bit more complicated than usual to exclude ".dired" -local variable files. - -@node Multiple Dired Directories, Dired Local Variables, Virtual Dired, Tree Dired Extra -@section Multiple Dired Directories and Non-Dired Commands - -@cindex Multiple Dired directories -@cindex Working directory -An Emacs buffer can have but one working directory, stored in the -buffer-local variable @code{default-directory}. A Dired buffer may have -several subdirectories inserted, but still has but one working -directory: that of the top level Dired directory in that buffer. For -some commands it is appropriate that they use the current Dired -directory instead of @code{default-directory}, e.g., @code{find-file} and -@code{compile}. - -A general mechanism is provided for special handling of the working -directory in special major modes: - -@table @code -@item default-directory-alist -@vindex default-directory-alist -Default: @code{((dired-mode . (dired-current-directory)))} - -Alist of major modes and their opinion on @code{default-directory}, as a -lisp expression to evaluate. A resulting value of @code{nil} is ignored -in favor of @code{default-directory}. - -@item default-directory -@findex default-directory -Function with usage like variable @code{default-directory}, but knows about the -special cases in variable @code{default-directory-alist}. -@end table - -The following dired-x commands take special care about the current -Dired directory: - -@table @code - -@item find-this-file -@findex find-this-file -@findex find-file -@kindex C-x C-f -Bind this to @kbd{C-x C-f} as a replacement for @code{find-file} that -will prompt for the filename within the current Dired subdirectory, not -the top level directory. - -@item find-this-file-other-window -@findex find-this-file-other-window -@findex find-file-other-window -@kindex C-x 4 C-f -Bind this to @kbd{C-x 4 C-f} as a replacement for -@code{find-file-other-window}. - -@item dired-smart-shell-command -@findex dired-smart-shell-command -@findex shell-command -@kindex M-! -Like function @code{shell-command}, but in the current Tree Dired directory. -Bound to @kbd{M-!} in Dired buffers. - -@item dired-smart-background-shell-command -@findex dired-smart-background-shell-command -@findex background -@kindex M-& -Like function @code{background}, but in the current Tree Dired directory. -Bound to @kbd{M-&} in Dired buffers. - -@item dired-jump-back -@findex dired-jump-back -@kindex C-x j -(Suggested binding @kbd{C-x j}) Jump back to dired: If in a file, dired -the current directory and move to file's line. If in Dired already, pop -up a level and goto old directory's line. In case the proper Dired file -line cannot be found, refresh the Dired buffer and try again. - -@item dired-jump-back-other-window -@findex dired-jump-back-other-window -@kindex C-x 4 j -(Suggested binding @kbd{C-x 4 j}) Like @code{dired-jump-back}, but to -other window. - -@item dired-vm -@kindex V -@findex dired-vm -@vindex vm-folder-directory -(@kbd{V}) Run VM on this file (assumed to be a UNIX mail folder). -Further `v' commands from within VM in that folder will default to the -folder's directory, not the usual @code{vm-folder-directory}. - -@vindex dired-vm-read-only-folders -If you give this command a prefix argument, it will visit the folder -read-only. This only works in VM 5, not VM 4. - -If the variable @code{dired-vm-read-only-folders} is t, @code{dired-vm} -will visit all folders read-only. If it is neither @code{nil} nor -@code{t}, e.g., the symbol @code{'if-file-read-only}, only files not -writable by you are visited read-only. This is the recommended value if -you run VM 5. - -@item dired-rmail -@findex dired-rmail -Run Rmail on this file (assumed to be mail folder in Rmail/BABYL format). - -@end table - -@c subsection Narrow and Widen in a Dired Buffer - -@node Dired Local Variables, Making Relative Symbolic Links in Dired, Multiple Dired Directories, Tree Dired Extra -@section Local Variables for Dired Directories - -@cindex Local Variables for Dired Directories -@vindex dired-local-variables-file -When Dired visits a directory, it looks for a file whose name is the -value of variable @code{dired-local-variables-file} (default: -@file{.dired}). If such a file is found, Dired will temporarily insert -it into the Dired buffer and run @code{hack-local-variables}. -@xref{File Variables,Local Variables in Files,Local Variables in -Files,emacs,The GNU Emacs Manual}. You can set -@code{dired-local-variables-file} to @code{nil} to suppress this. - -For example, put - -@example -Local Variables: -dired-actual-switches: "-lat" -dired-sort-mode: " by date" -End: -@end example - -into a @file{.dired} file of a directory to sort by date only in that -directory. Note that since @code{dired-hack-local-variables} is run -inside @code{dired-mode-hook} the modeline has already been set, so you -have to update that for yourself by setting @code{dired-sort-mode} in -addition to changing the switches. - -@node Making Relative Symbolic Links in Dired, Letting Dired Guess What Shell Command to Apply, Dired Local Variables, Tree Dired Extra -@section Making Relative Symbolic Links in Dired - -In GNU Emacs version 18, the built-in function @code{make-symbolic-link} -always calls @code{expand-file-name} on its arguments, so relative -symlinks (e.g. @samp{foo -> ../bar/foo}) are impossible to create. - -Dired Extra uses @code{call-process} and @samp{ln -s} for a workaround. - -@table @code - -@item dired-make-symbolic-link -@findex dired-make-symbolic-link -Arguments @var{name1} @var{name2} and optional -@var{ok-if-already-exists}. Create file @var{name2}, a symbolic link -pointing to @var{name1} (which may be any string whatsoever and is -passed untouched to @samp{ln -s}). @var{ok-if-already-exists} means that -@var{name2} will be overwritten if it already exists. If it is an -integer, user will be asked about this. On error, signals a file-error. - -@item dired-make-relative-symlink -@findex dired-make-relative-symlink -Three arguments: @var{file1} @var{file2} and optional -@var{ok-if-already-exists}. Make a symbolic link @var{file2} (pointing -to @var{file1}). The link is relative (if possible), for example - -@example -(dired-make-relative-symlink "/vol/tex/bin/foo" - "/vol/local/bin/foo") -@end example - -@noindent -results in a link - -@example -/vol/local/bin/foo -> ../../tex/bin/foo -@end example - -@item dired-do-relsymlink -@findex dired-do-relsymlink -(binding @kbd{S}) Symbolically link all marked (or next @var{N}) files -into a directory, or make a symbolic link to the current file. This -creates relative symbolic links like - -@example - foo -> ../bar/foo -@end example - -@noindent -not absolute ones like -@example - foo -> /ugly/path/that/may/change/any/day/bar/foo -@end example - -@item dired-do-relsymlink-regexp -@findex dired-do-relsymlink-regexp -(@kbd{%S}) Symbolically link all marked files containing @var{regexp} to -@var{newname}, using relative (not absolute) names. See functions -@code{dired-rename-regexp} and @code{dired-do-relsymlink} for more info. - -@end table - -@node Letting Dired Guess What Shell Command to Apply, dired-trns.el, Making Relative Symbolic Links in Dired, Tree Dired Extra -@section Letting Dired Guess What Shell Command to Apply - -Based upon the name of a filename, Dired tries to guess what shell -command you might want to apply to it. For example, if you have point -on a file named @file{foo.tar} and you press @kbd{!}, Dired will guess -you want to @samp{tar xvf} it and suggest that as the default shell -command. - -If you are using the @file{gmhist} package (@xref{Dired Minibuffer -History}), the default will be mentioned in brackets and you can type -@kbd{M-p} to get the default into the minibuffer so that you can edit -it, e.g., changing @samp{tar xvf} to @samp{tar tvf}. If there are -several commands for a given file, e.g., @samp{xtex} and @samp{dvips} -for a @file{.dvi} file, you can type @kbd{M-p} several times to see each -of the matching commands. - -Dired only tries to guess a command for a single file, never for a list -of marked files. - -@table @code - -@item dired-auto-shell-command-alist-default -@vindex dired-auto-shell-command-alist-default - -Predefined rules for shell commands. Set this to nil to turn guessing off. -The elements of @code{dired-auto-shell-command-alist} (defined by the -user) will override these rules.@refill - -@item dired-auto-shell-command-alist -@vindex dired-auto-shell-command-alist - -If non-nil, an alist of file regexps and their suggested commands -overriding the predefined rules in -@code{dired-auto-shell-command-alist-default}.@refill - -Each element of the alist looks like - -@example -(@var{regexp} @var{command}@dots{}) -@end example - -where each @var{command} can either be a string or a lisp expression -that evaluates to a string. If several @var{COMMAND}s are given, all -will temporarily be pushed on the history. - -These rules take precedence over the predefined rules in the variable -@code{dired-auto-shell-command-alist-default} (to which they are -prepended when @file{dired-x} is loaded). - -You can set this variable in your @file{~/.emacs}. For example, -to add rules for @samp{.foo} and @samp{.bar} file extensions, write - -@example -(setq dired-auto-shell-command-alist - (list - (list "\\.foo$" "@var{foo-command}");; fixed rule - ;; possibly more rules... - (list "\\.bar$";; rule with condition test - '(if @var{condition} - "@var{bar-command-1}" - "@var{bar-command-2}")))) -@end example - -@noindent -This will override any predefined rules for the same extensions. - -@item dired-guess-have-gnutar -@vindex dired-guess-have-gnutar - -Default: @code{nil} - -If non-nil, name of the GNU tar executable (e.g., @samp{"tar"} or -@samp{"gnutar"}). GNU tar's @samp{z} switch is used for compressed tar -files. If you don't have GNU tar, set this to nil: a pipe using -@samp{zcat} is then used. - -@end table - -@node dired-trns.el, dired-cd.el, Letting Dired Guess What Shell Command to Apply, Tree Dired Extra -@section Filename Transformers for Dired Shell Commands - -@cindex Transformer -@cindex Basename of a file, how to use in Dired shell commands -@cindex Extension of a file, how to use in Dired shell commands -File name @dfn{transformers} are functions that take a filename (a string) -as an argument and transform it into some other string (e.g., a filename -without an extension). This package makes transformers available in -Dired shell commands. - -For example, running the Dired shell command (type @kbd{!} or @kbd{M-x} -@code{dired-do-shell-command})@refill - -@example -echo * [b] [db] -@end example - -would list the full name, the basename, and the absolute basename of -each marked file. - -Each transformer is associated with a dispatch character. The associations -are stored in a keymap for fast and easy lookup. The dispatch character -is used to activate the associated transformer function at a particular -position in a shell command issued in Dired. The dispatch character -must be enclosed in brackets to distinguish it from normal letters. - -To take advantage of this package, simply load it after loading Dired, -e.g., in your @code{dired-load-hook}. You can then use transformers like -"[b]" for the basename in your Dired shell commands (see below). - -You can define your own transformers using the macro @code{dired-trans-define}. - -@table @code - -@item dired-trans-define -@findex dired-trans-define -Macro that assigns the transformer function @code{(lambda (file) -@var{body})} to @var{char} (a character or string). @var{body} must -return a string: the transformed file. -@end table - -Several transformers are predefined: - -@table @samp - -@item * -returns the unmodified filename (equivalent to @samp{[dbe]}). - -@item n -returns the Name component of a filename without directory information - -@item d -returns the Directory component of a filename - -@item b -returns the Basename of a filename, i.e., the name of the file without -directory and extension (see variable @code{dired-trans-re-ext}) -A basename with directory component can be obtained by @samp{[db]}. - -@item e -returns the Extension of a filename (i.e., whatever -@code{dired-trans-re-ext} splits off) - -@item v -returns a file without directory and without @file{,v} suffixes if any. - -@item z -returns a file without directory and without @file{.Z} suffixes if any. - -@end table - -@noindent -The following variables can be used to customize @file{dired-trns.el}: - -@table @code - -@item dired-trans-re-ext -@vindex dired-trans-re-ext -Default: @code{"\\.[^.]*\\(\\.Z\\)?$"} - -The part of a filename matching this regexp will be viewed as extension. - -@item dired-trans-starters -@vindex dired-trans-starters -Default: @code{"[#[]"} - -User definable set of characters to be used to indicate the start of a -transformer sequence. - -@item dired-trans-enders -@vindex dired-trans-enders -Default: @code{"[]# ]"} - -User definable set of characters to be used to indicate the end of a -transformer sequence. - -@end table - -@node dired-cd.el, dired-nstd.el, dired-trns.el, Tree Dired Extra -@section Changing the Working Directory for Dired Shell Commands - -The package @file{dired-cd.el} permits the working directory of the -Dired shell commands @kbd{!} (@code{dired-do-shell-command}) and @kbd{&} -(@code{dired-do-background-shell-command}) to be the files' subdirectory -under certain circumstances. Loading this extension does not change the -behavior of Dired until the variables @code{dired-cd-same-subdir} and/or -@code{dired-cd-on-each} are non-nil. - -@vindex dired-cd-same-subdir -If @code{dired-cd-same-subdir} is non-nil and if all the selected files -(marked, non-zero numeric argument, etc.) are in the same subdirectory, -then @code{dired-do-shell-command} and -@code{dired-do-background-shell-command} cause the shell to perform a -@samp{cd} into that directory before the commands are executed. Also, -the selected filenames are provided to the command without any directory -components. - -@vindex dired-cd-on-each -If @code{dired-cd-on-each} is non-nil and if the @samp{on-each} option -is specified (numeric argument of zero), then @kbd{!} -(@code{dired-do-shell-command}) and @kbd{&} -(@code{dired-mark-background-shell-command}) use a subshell to perform a -@samp{cd} into the subdirectory of each file before the commands on that -file are executed. Also, each filename is provided to the command -without any directory components. Note that this behavior occurs -regardless of whether the files are all in the same directory or not. - -After the above @samp{cd} wrapping has occured, the existing -@code{dired-shell-stuff-it} is used to do the actual file-name quoting -and substitution into the command. Thus, custom versions of this -procedure should work, e.g., the @samp{dired-trans} package will transform -commands correctly. However, since filenames lack any directory -components, features that use the directory components will fail, e.g. -the @samp{[d]} transform specifier will be empty. - -To use this package, load it in your @code{dired-load-hook}. Do - -@example -(setq dired-cd-same-subdir t) -@end example - -@noindent -and perhaps - -@example -(setq dired-cd-on-each t) -@end example - -@noindent -in your @file{~/.emacs}. By default, @code{dired-cd} doesn't change the -behavior of Dired when it is loaded. - -@vindex dired-cd-same-subdir -If @code{dired-cd-same-subdir} is non-nil, then the shell commands -@samp{cd} to the appropriate directory if all the selected files are in -that directory; however, on-each behavior (with zero prefix argument) is -not changed. - -@vindex dired-cd-on-each -If @code{dired-cd-on-each} is non-nil, then each instance of the command -for an on-each shell command runs in the file's directory regardless of -whether the files are all in the same directory. - -@node dired-nstd.el, find-dired.el, dired-cd.el, Tree Dired Extra -@section Nested Dired format - -[NO DOCUMENTATION YET] - -This is still buggy, @xref{Dired Known Problems}. - -@node find-dired.el, , dired-nstd.el, Tree Dired Extra -@section Feeding Find Output to Dired - -@cindex Find and Dired -The @code{find-dired} command runs the @samp{find} command in a buffer -and starts Dired on the inserted file lines, even while @samp{find} is -still running. For example, with @samp{-type d} as argument, you will -get a Dired buffer that contains all subdirectories of a given -directory, but none of the other files. - -Note that @samp{find} just gives you file lines, not inserted -subdirectories with associated headerlines as repeated use of the -@kbd{i} (@code{dired-maybe-insert-subdir}) command would. Also, the -names contain slashes if they are in a subdirectory, which never occurs -in a normal Dired buffer. Dired understands these names anyway and you -can for example type @kbd{f} on such lines as usual. However, while -@samp{find} is still running you shouldn't type @kbd{i} to insert -subdirectories, since new @samp{find} output is always appended at the -end. Use @kbd{f} or @kbd{o} instead to dired the specific subdirectory -in a new Dired buffer. After @samp{find} has finished (as indicated by -a message and the modeline) all Dired commands work as usual. - -@table @code - -@item find-dired -@findex find-dired -Run @samp{find} on a directory @var{dir}, with find arguments -@var{args}, and go into dired-mode on a buffer of the output. The -command run (after changing into @var{dir}) is -@example -find . \( @var{args} \) -ls -@end example - -@item find-name-dired -@findex find-name-dired -Search @var{dir} recursively for files matching the globbing pattern -@var{pattern}, and run Dired on those files. @var{pattern} is a shell -wildcard (not an Emacs regexp) and need not be quoted. The command -run (after changing into @var{dir}) is -@example - find . -name '@var{pattern}' -ls -@end example - -@item find-grep-dired -@findex find-grep-dired -Find files in directory @var{dir} containing a regexp @var{arg} and -start Dired on output. The command run (after changing into @var{dir}) -is -@example -find . -exec grep -s @var{arg} @{@} \; -ls -@end example -@end table - -@node Dired Internals, Dired Known Problems, Tree Dired Extra, Top -@appendix Dired Internals - -This is a short introduction about how Dired's Tree and Mark features -work. You are encouraged to read the code (@file{dired.el}) for more -information. - -@menu -* Tree Dired Internals:: -* Dired Mark Internals:: -@end menu - -@node Tree Dired Internals, Dired Mark Internals, Dired Internals, Dired Internals -@section Tree Dired Internals - -@cindex Internals of Tree Dired -@cindex Tree Dired Internals -@vindex dired-subdir-alist -@vindex default-directory -In Tree Dired, instead of just one directory, all or part of the -directory @emph{tree} starting at the top level directory (the working -directory or @code{default-directory} of the buffer) may be in a -Dired buffer. Each file line belongs to exactly one of those -subdirectories. After the @code{ls} program has inserted its output, -Dired parses the buffer once to find out where the subdirectory -boundaries are and saves them in the variable @code{dired-subdir-alist}. -The beginning of the headerline inserted by @code{ls} serves as boundary -between subdirectories. - -@kindex i -@findex dired-maybe-insert-subdir -Subsequent @kbd{i} (@code{dired-maybe-insert-subdir}) commands update this -alist and insert the appropriate headerline. Each retrieval of the -filename on the current line first extracts the basename (assuming a -more or less standard @code{ls} output format), and then function -@code{dired-current-directory} looks up the current Dired directory in -@code{dired-subdir-alist}. The lookup is keyed on buffer position, as -each buffer position is between exactly two subdirectory boundaries. (The end -of the buffer serves as an implicit subdirectory boundary.) - -@table @code - -@item dired-subdir-alist -@vindex dired-subdir-alist -Association list of subdirectories and their buffer positions: - -@example -((@var{lastdir} . @var{lastmarker}) @dots{} (@var{default-directory} . @var{firstmarker})). -@end example - -The markers point right before the beginning of the line, so that they -separate subdirectories adjacent in the buffer. The directories must be -in the form returned by @code{file-name-as-directory}. - -@item dired-subdir-regexp -@vindex dired-subdir-regexp -Value: "^. \\([^ \n\r]+\\)\\(:\\)[\n\r]" - -Regexp matching a maybe hidden subdirectory line in @samp{ls -lR} -output. Subexpression 1 is subdirectory proper, no trailing colon. The -match starts at the beginning of the line and ends after the end of the -line (@samp{\n} or @samp{\r}). Subexpression 2 must end right before -the @samp{\n} or @code{\r}. This is so that Dired can easily check -whether a subdirectory is hidden or not: hidden lines end with @samp{\r} -(@kbd{C-m}) instead of a newline. - -This regexp used to be @code{"^. \\(/[^\n\r]*\\)\\(:\\)[\n\r]"}, -allowing spaces, but disallowing relative filenames (which occur when -browsing ls -lR listing in virtual Dired mode, so I changed it). - -Note that @code{"^. \\([^\n\r]+\\)\\(:\\)[\n\r]"} (desirable since it -allows both spaces and relative names) will not always work: if you have -a file that ends in a colon, its whole line (including permission bits, -date etc.) would be mistaken for a subdirectory headerline when parsing -@samp{ls -lR} output. - -@code{dired-subdir-regexp} is only relevant for parsing @samp{ls -lR} -output. If Dired inserts subdirectories itself (using -@code{dired-insert-subdir}), they will always be absolute and there is -no restriction on the format of filenames, e.g., they can contain -spaces. - -@end table - -@node Dired Mark Internals, , Tree Dired Internals, Dired Internals -@section Dired Mark Internals - -This is a short overview about how marking files and retrieving marked -files in Dired works. - -@cindex Internal of Dired file marking -@cindex Dired file marking internals -@cindex File marking internals in Dired -@cindex Marking files in Dired, internals of -@code{ls} output is indented two spaces two make room for an optional -marker character in front of each file line. Marking simply replaces the -first space with the marker character, usually @code{*} or, for -deletions, @code{D}. Indenting just by one would leave the markers -adjacent to the permission bits. - -@table @code - -@item dired-mark-if -@findex dired-mark-if -The macro @code{dired-mark-if} is used internally to mark files matching -certain criteria. It takes two arguments, the @var{predicate}, a lisp -expression evaluating non-nil on file lines to be marked, and @var{msg}, -a message to be displayed while scanning the buffer. @var{msg} may be -nil to suppress the message. - -@findex dired-mark-map -@item dired-mark-map -To operate on the marked files, all internal Dired functions ultimately -call the macro @code{dired-mark-map}. It takes two arguments, -@var{body} and @var{arg}, plus an optional argument @var{show-progress}: - -Perform @var{body} with point somewhere on each marked line (inside a -@code{save-excursion}) and return a list of @var{body}'s results. If no -marked file could be found, execute @var{body} on the current line. - -If @var{arg} is an integer, use the next @var{arg} (or previous --@var{arg}, if @var{arg}<0) files instead of the marked files. In that -case point is dragged along. This is so that commands on the next ARG -(instead of the marked) files can be chained easily. Note that for -positive ARG point is left on the first file not operated upon, for -negative on the last file operated upon - -If @var{arg} is otherwise non-nil, use current file instead. - -If optional third argument @var{show-progress} evaluates to non-nil, we -redisplay the Dired buffer after each file is processed. No guarantee -is made about the position on the marked line. @var{body} must ensure -this itself if it depends on this. Search starts at the beginning of -the buffer, thus the @code{car} of the list corresponds to the line nearest to -the buffer's bottom. This is also true for (positive and negative) -integer values of @var{arg}. The @var{body} should not be too long as -it is expanded four times.@refill - -@c This warning should no longer apply. sk 6-Sep-1991 16:28 -@c Warning: @var{body} must not add new lines before point - this may cause -@c an endless loop. - -@end table - -@noindent -A common case is to retrieve the names of all marked files: - -@table @code - -@findex dired-mark-get-files -@item dired-mark-get-files -Return the marked files as list of strings. The list is in the same -order as the buffer, that is, the car is the first marked file. Values -returned are normally absolute pathnames. Optional argument @var{localp} -equal to @code{no-dir} means return the filename proper only, with no -directory information; any other non-nil value means make them relative -to default-directory. Optional second argument @var{arg} forces use of -other files. If @var{arg} is an integer, use the next @var{arg} files. -If @var{arg} is otherwise non-nil, use the current file. - -@end table - -@node Dired Known Problems, Dired Variable Index, Dired Internals, Top -@appendix Known Problems with Dired - -There are some problems with Dired that are either not Dired's fault, -hard to fix or not worth fixing. - -@itemize @bullet - -@item -Renaming directories usually works fine (all affected Dired and file -buffers are updated), but moving a directory between different -filesystems (those on different hard disks or different partitions) does -not work: it creates a plain target file containing the contents of the -original directory (inodes and filenames) or fails completely. - -Unfortunately Emacs' builtin function @code{rename-file} does not give -you a clear error message like @samp{cross-device link attempted}, but -rather a spurious @code{(file-error "Removing old name" "not owner")}, -at least in Emacs 18.55. - -On some systems renaming a directory always fails (even within -the same filesystem) with the spurious @samp{not owner} error. -@c This was reported for HP-UX. -@c -@c On one system (IBM Rs6000 running AIX 3.1.3) date lossage was reported, -@c but this was not reproducible. - -@item -If @file{foo} is a symlink to a non-existing file, @code{(file-exists-p -"foo")} returns nil. Thus, Dired will overwite such (strange) kinds of -symlinks without noticing. - -Dired could test both @code{file-symlink-p} and @code{file-exists-p}, -but this would slow down all file operations to catch a very rare case. - -@item -Copying a directory does not work - it results in a zero-length -target file. - -This comes from Emacs' @code{copy-file} function, not from Dired. - -If you really want to copy a directory (recursively), use `!' and -your favorite shell command to do it (e.g. cp -R or cp -r). - -@item -Initial spaces in a filename are not recognized. If I could be sure -that all @samp{ls} programs insert exactly one space between the time and -the filename, I could easily fix this. But @samp{ls} programs tend to vary -in their amount of white space, and even with one @samp{ls} program there -is a difference between year and clocktime formats -@example - drwxr-xr-x 2 ab027 thp 512 Aug 13 1990 thp/ - drwxr-xr-x 4 ab027 thp 512 Feb 3 21:59 ./ -@end example -If your @samp{ls} supports the @samp{-b} switch and quotes spaces with -that switch, simply add @samp{b} to your @code{dired-listing-switches}. -@xref{Listing Files in Dired}. - -Spaces anywhere but at the beginning do work. - -@item -In general, only commands that may have targets outside of the -current directory tree update other buffers (copy, move and link -commands). - -Especially, deletions, (un)compress, chmod/chgrp/chown update only -the current buffer. - -@item -Some compress programs make output even if all goes well. Dired -takes output as a sign of trouble and assumes that the subprocess -failed. - -Redefine function @code{dired-check-process-checker} suitably to -look closer at the generated output. In Emacs 19, the exit status -of compress will be checked. - -@item -Aliases like @samp{rm -i} for @samp{rm} or @samp{ls -F} for @samp{ls} -can cause problems in Dired's (and Emacs') shell command. (Aliases for -@samp{ls} only matter if you dired wildcards, because only then the shell is -used to run @samp{ls}.) Csh expands aliases only for interactive shells, which -is probably what you want. In Bash, you can achieve this by testing -@code{PS1} in your @file{~/.bashrc}: -@example - # `.bashrc' file - # this test fails when invoked by rsh - if [ "$@{PS1-no@}" != "no" ] # is this an interactive shell? - then - . ~/.bash_alias # if so, source aliases - fi -@end example - -@item -Directory names starting with @file{-} (a minus) may lose when they are -to be created or removed. If you care about this, and your rmdir -and mkdir understand about @file{--} meaning end of options, change -@file{emacs-19.el} accordingly. - -In Emacs 19 the @code{make-directory} and @code{remove-directory} -operations will be builtin, not implemented with @samp{rmdir} and -@samp{mkdir} subprocesses. - -@item -@file{dired-nstd.el}: This is still buggy. For example, after you've -compressed the last file it may not correctly return that file's -absolute pathname (@code{dired-current-directory} erronously returns nil -because of markers collapsed during redisplay), ultimately leading to -lisp errors. - -@c Not longer a problem as of dired-version 5.242, sk 28-Jan-1992 11:17. -@c @item -@c Symbolic links to directories are sometimes strange. On System V -@c derived systems (e.g., DG/UX, AIX/370), after -@c @example -@c mkdir dir; ln -s dir link -@c @end example -@c both @file{link} and @file{link/} are considered symbolic links by the -@c @samp{stat(2)} system call, while on BSD derived systems (e.g., Sun OS, -@c Mach, HP/UX, Ultrix) @file{link/} is considered a directory. In -@c general, the BSD behaviour is preferable, at least for Dired. On the -@c other systems it is cumbersome to get Dired to dereference those links. - -@item -The regexp-using @kbd{%}-commands get into an endless loop if you -specify a regular expression that matches the empty string. - -@item -Function @code{find-alternate-file} in Emacs 18.57 has a bug that causes -@kbd{C-x C-v RET} (which usually re-visits the current buffer) to fail -on Dired buffers. This is fixed in the version in @file{emacs-19.el}, -automatically loaded by Dired. - -@item -It is not possible to resort the Dired buffer without reverting it. That -would be hard to implement (and slow to run) given that ls date format -would have to be parsed for @samp{ls -t} sorting order. - -@end itemize - -@node Dired Variable Index, Dired Function Index, Dired Known Problems, Top -@unnumbered Dired Variable Index -@printindex vr - -@node Dired Function Index, Dired Key Index, Dired Variable Index, Top -@unnumbered Dired Function Index -@printindex fn - -@node Dired Key Index, Dired Concept Index, Dired Function Index, Top -@unnumbered Dired Key Index -@printindex ky - -@node Dired Concept Index, , Dired Key Index, Top -@unnumbered Dired Concept Index -@printindex cp - -@c @summarycontents -@contents - -@bye - diff -r 498bf5da1c90 -r 0d2f883870bc man/gnus-faq.texi --- a/man/gnus-faq.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/gnus-faq.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,14 +1,14 @@ \input texinfo @c -*-texinfo-*- @c Copyright (C) 1995 Free Software Foundation, Inc. -@setfilename ../info/gnus-faq.info +@setfilename gnus-faq.info @node Frequently Asked Questions @section Frequently Asked Questions This is the Gnus Frequently Asked Questions list. If you have a Web browser, the official hypertext version is at -@file{http://www.miranova.com/~steve/gnus-faq.html>}, and has +@file{http://www.ccs.neu.edu/software/gnus/}, and has probably been updated since you got this manual. @menu @@ -183,7 +183,7 @@ @item Q1.10 Mailcrypt 3.4 doesn't work -This problem is verified to still exist in Gnus 5.0.9 and MailCrypt 3.4. +This problem is verified to still exist in Gnus 5.0.9 and Mailcrypt 3.4. The answer comes from Peter Arius . diff -r 498bf5da1c90 -r 0d2f883870bc man/gnus.texi --- a/man/gnus.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/gnus.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- -@setfilename ../info/gnus.info -@settitle Gnus 5.2 Manual +@setfilename gnus +@settitle Gnus 5.4 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -14,11 +14,8 @@ @iflatex \documentclass[twoside,a4paper,openright]{book} \usepackage[latin1]{inputenc} -% \usepackage{fontenc} -% \usepackage{babel} \usepackage{pagestyle} \usepackage{epsfig} -% \usepackage{ifitricks} \fontfamily{bembo}\selectfont \makeindex @@ -57,6 +54,7 @@ \newcommand{\gnushash}{\#} \newcommand{\gnushat}{\symbol{"5E}} \newcommand{\gnusunderline}{\symbol{"5F}} +\newcommand{\gnusnot}{$\neg$} \newcommand{\gnustilde}{\symbol{"7E}} \newcommand{\gnusless}{{$<$}} \newcommand{\gnusgreater}{{$>$}} @@ -66,16 +64,31 @@ \marginpar[\hspace{2.5cm}\gnushead]{\gnushead} } -\newcommand{\gnuschapter}[1]{ +\newcommand{\gnuscleardoublepage}{\ifodd\count0\mbox{}\clearpage\thispagestyle{empty}\mbox{}\clearpage\else\clearpage\fi} + +\newcommand{\gnuspagechapter}[1]{ +{\mbox{}} +} + +\newdimen{\gnusdimen} +\gnusdimen 0pt + +\newcommand{\gnuschapter}[2]{ +\gnuscleardoublepage +\ifdim \gnusdimen = 0pt\setcounter{page}{1}\pagestyle{gnus}\pagenumbering{arabic} \gnusdimen 1pt\fi +\chapter{#2} \renewcommand{\gnussectionname}{} -\chapter{#1} -\renewcommand{\gnuschaptername}{#1} +\renewcommand{\gnuschaptername}{#2} \thispagestyle{empty} -% \epsfig{figure=gnus-herd-\arabic{chapter}.eps,height=15cm} +\hspace*{-2cm} +\begin{picture}(500,500)(0,0) +\put(0,0){\makebox(480,350)[tr]{#1}} +\put(40,300){\makebox(500,50)[bl]{{\Huge\bf{#2}}}} +\end{picture} \clearpage } -\newcommand{\gnusitemx}[1]{\vspace{-\itemsep}\item#1} +\newcommand{\gnusitemx}[1]{\mbox{}\vspace*{-\itemsep}\vspace*{-\parsep}\item#1} \newcommand{\gnussection}[1]{ \renewcommand{\gnussectionname}{#1} @@ -118,27 +131,21 @@ } }{\end{list}} -\newpagestyle{gnus}% +\newlength\gnusheadtextwidth +\setlength{\gnusheadtextwidth}{\headtextwidth} +\addtolength{\gnusheadtextwidth}{1cm} + +\newpagestyle{gnuspreamble}% { { \ifodd\count0 { -\hspace*{-2ex} -\underline{ -\makebox[\headtextwidth]{ -\hspace*{-2.3ex} -\textbf{\arabic{chapter}.\arabic{section}} -\textbf{\gnussectionname\hfill\arabic{page}} -}} +\hspace*{-0.23cm}\underline{\makebox[\gnusheadtextwidth]{\mbox{}}\textbf{\hfill\roman{page}}} } \else { -\hspace*{-2.25cm} -\underline{ -\hspace*{-2.3ex} -\makebox[\headtextwidth]{ -\textbf{\arabic{page}\hfill\gnuschaptername} -}} +\hspace*{-3.25cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\roman{page}\hfill\mbox{}}} +} } \fi } @@ -152,7 +159,57 @@ \hfill \mbox{} \fi } -\pagestyle{gnus} + +\newpagestyle{gnusindex}% +{ +{ +\ifodd\count0 +{ +\hspace*{-0.23cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\gnuschaptername\hfill\arabic{page}}}} +} +\else +{ +\hspace*{-3.25cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{page}\hfill\gnuschaptername}}} +} +\fi +} +} +{ +\ifodd\count0 +\mbox{} \hfill +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\else +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\hfill \mbox{} +\fi +} + +\newpagestyle{gnus}% +{ +{ +\ifodd\count0 +{ +\hspace*{-0.23cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{chapter}.\arabic{section}} \textbf{\gnussectionname\hfill\arabic{page}}}} +} +\else +{ +\hspace*{-3.25cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{page}\hfill\gnuschaptername}}} +} +\fi +} +} +{ +\ifodd\count0 +\mbox{} \hfill +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\else +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\hfill \mbox{} +\fi +} + +\pagenumbering{roman} +\pagestyle{gnuspreamble} @end iflatex @end iftex @@ -230,7 +287,7 @@ @tex @titlepage -@title Gnus Manual +@title Gnus 5.4 Manual @author by Lars Magne Ingebrigtsen @page @@ -266,12 +323,15 @@ spool or your mbox file. All at the same time, if you want to push your luck. +This manual corresponds to Gnus 5.4. + @end ifinfo @iftex @iflatex -\thispagestyle{empty} +\tableofcontents +\gnuscleardoublepage @end iflatex Gnus is the advanced, self-documenting, customizable, extensible @@ -310,7 +370,6 @@ * Key Index:: Key Index. @end menu - @node Starting Up @chapter Starting Gnus @cindex starting up @@ -333,18 +392,20 @@ * Finding the News:: Choosing a method for getting news. * The First Time:: What does Gnus do the first time you start it? * The Server is Down:: How can I read my mail then? -* Slave Gnusii:: You can have more than one Gnus active at a time. +* Slave Gnusae:: You can have more than one Gnus active at a time. * Fetching a Group:: Starting Gnus just to read a group. * New Groups:: What is Gnus supposed to do with new groups? * Startup Files:: Those pesky startup files---@file{.newsrc}. * Auto Save:: Recovering from a crash. * The Active File:: Reading the active file over a slow line Takes Time. +* Changing Servers:: You may want to move from one server to another. * Startup Variables:: Other variables you might change. @end menu @node Finding the News @section Finding the News +@cindex finding news @vindex gnus-select-method @c @head @@ -378,7 +439,7 @@ Gnus will see whether @code{gnus-nntpserver-file} (@file{/etc/nntpserver} by default) has any opinions on the matter. If that fails as well, Gnus will will try to use the machine that is -running Emacs as an @sc{nntp} server. That's a long-shot, though. +running Emacs as an @sc{nntp} server. That's a long shot, though. @vindex gnus-nntp-server If @code{gnus-nntp-server} is set, this variable will override @@ -461,51 +522,56 @@ buffer. But, hey, that's your problem. Blllrph! @findex gnus-no-server +@kindex M-x gnus-no-server @c @head If you know that the server is definitely down, or you just want to read your mail without bothering with the server at all, you can use the @code{gnus-no-server} command to start Gnus. That might come in handy -if you're in a hurry as well. - - -@node Slave Gnusii -@section Slave Gnusiï +if you're in a hurry as well. This command will not attempt to contact +your primary server---instead, it will just activate all groups on level +1 and 2. (You should preferably keep no native groups on those two +levels.) + + +@node Slave Gnusae +@section Slave Gnusae @cindex slave You might want to run more than one Emacs with more than one Gnus at the -same time. If you are using different @file{.newsrc} files (eg., if you -are using the two different Gnusiï to read from two different servers), +same time. If you are using different @file{.newsrc} files (e.g., if you +are using the two different Gnusae to read from two different servers), that is no problem whatsoever. You just do it. -The problem appears when you want to run two Gnusiï that use the same +The problem appears when you want to run two Gnusae that use the same @code{.newsrc} file. To work around that problem some, we here at the Think-Tank at the Gnus Towers have come up with a new concept: @dfn{Masters} and -@dfn{servants}. (We have applied for a patent on this concept, and have +@dfn{slaves}. (We have applied for a patent on this concept, and have taken out a copyright on those words. If you wish to use those words in conjunction with each other, you have to send $1 per usage instance to me. Usage of the patent (@dfn{Master/Slave Relationships In Computer Applications}) will be much more expensive, of course.) Anyways, you start one Gnus up the normal way with @kbd{M-x gnus} (or -however you do it). Each subsequent slave Gnusiï should be started with +however you do it). Each subsequent slave Gnusae should be started with @kbd{M-x gnus-slave}. These slaves won't save normal @file{.newsrc} -files, but instead save @dfn{slave files} that contains information only +files, but instead save @dfn{slave files} that contain information only on what groups have been read in the slave session. When a master Gnus starts, it will read (and delete) these slave files, incorporating all information from them. (The slave files will be read in the sequence they were created, so the latest changes will have precedence.) Information from the slave files has, of course, precedence over the -information in the normal (i. e., master) @code{.newsrc} file. +information in the normal (i.e., master) @code{.newsrc} file. @node Fetching a Group @section Fetching a Group +@cindex fetching a group @findex gnus-fetch-group -It it sometime convenient to be able to just say ``I want to read this +It it sometimes convenient to be able to just say ``I want to read this group and I don't care whether Gnus has been started or not''. This is perhaps more useful for people who write code than for users, but the command @code{gnus-fetch-group} provides this functionality in any case. @@ -515,6 +581,61 @@ @node New Groups @section New Groups @cindex new groups +@cindex subscription + +@vindex gnus-check-new-newsgroups +If you are satisfied that you really never want to see any new groups, +you can set @code{gnus-check-new-newsgroups} to @code{nil}. This will +also save you some time at startup. Even if this variable is +@code{nil}, you can always subscribe to the new groups just by pressing +@kbd{U} in the group buffer (@pxref{Group Maintenance}). This variable +is @code{t} by default. If you set this variable to @code{always}, then +Gnus will query the backends for new groups even when you do the @kbd{g} +command (@pxref{Scanning New Messages}). + +@menu +* Checking New Groups:: Determining what groups are new. +* Subscription Methods:: What Gnus should do with new groups. +* Filtering New Groups:: Making Gnus ignore certain new groups. +@end menu + + +@node Checking New Groups +@subsection Checking New Groups + +Gnus normally determines whether a group is new or not by comparing the +list of groups from the active file(s) with the lists of subscribed and +dead groups. This isn't a particularly fast method. If +@code{gnus-check-new-newsgroups} is @code{ask-server}, Gnus will ask the +server for new groups since the last time. This is both faster and +cheaper. This also means that you can get rid of the list of killed +groups altogether, so you may set @code{gnus-save-killed-list} to +@code{nil}, which will save time both at startup, at exit, and all over. +Saves disk space, too. Why isn't this the default, then? +Unfortunately, not all servers support this command. + +I bet I know what you're thinking now: How do I find out whether my +server supports @code{ask-server}? No? Good, because I don't have a +fail-safe answer. I would suggest just setting this variable to +@code{ask-server} and see whether any new groups appear within the next +few days. If any do, then it works. If none do, then it doesn't +work. I could write a function to make Gnus guess whether the server +supports @code{ask-server}, but it would just be a guess. So I won't. +You could @code{telnet} to the server and say @code{HELP} and see +whether it lists @samp{NEWGROUPS} among the commands it understands. If +it does, then it might work. (But there are servers that lists +@samp{NEWGROUPS} without supporting the function properly.) + +This variable can also be a list of select methods. If so, Gnus will +issue an @code{ask-server} command to each of the select methods, and +subscribe them (or not) using the normal methods. This might be handy +if you are monitoring a few servers for new groups. A side effect is +that startup will take much longer, so you can meditate while waiting. +Use the mantra ``dingnusdingnusdingnus'' to achieve permanent bliss. + + +@node Subscription Methods +@subsection Subscription Methods @vindex gnus-subscribe-newsgroup-method What Gnus does when it encounters a new group is determined by the @@ -527,9 +648,9 @@ @item gnus-subscribe-zombies @vindex gnus-subscribe-zombies -Make all new groups zombies. You can browse the zombies later (with -@kbd{A z}) and either kill them all off properly, or subscribe to them. -This is the default. +Make all new groups zombies. This is the default. You can browse the +zombies later (with @kbd{A z}) and either kill them all off properly +(with @kbd{S z}), or subscribe to them (with @kbd{u}). @item gnus-subscribe-randomly @vindex gnus-subscribe-randomly @@ -539,15 +660,15 @@ @vindex gnus-subscribe-alphabetically Subscribe all new groups alphabetically. -@item gnus-subscribe-hierarchically -@vindex gnus-subscribe-hierarchically +@item gnus-subscribe-hierarchically +@vindex gnus-subscribe-hierarchically Subscribe all new groups hierarchically. The difference between this function and @code{gnus-subscribe-alphabetically} is slight. -@code{gnus-subscribe-alphabetically} will subscribe new groups in a -strictly alphabetical fashion, while this function will enter groups -into it's hierarchy. So if you want to have the @samp{rec} hierarchy -before the @samp{comp} hierarchy, this function will not mess that -configuration up. Or something like that. +@code{gnus-subscribe-alphabetically} will subscribe new groups in a strictly +alphabetical fashion, while this function will enter groups into it's +hierarchy. So if you want to have the @samp{rec} hierarchy before the +@samp{comp} hierarchy, this function will not mess that configuration +up. Or something like that. @item gnus-subscribe-interactively @vindex gnus-subscribe-interactively @@ -572,6 +693,10 @@ @code{gnus-subscribe-hierarchical-interactive}. This is an error. This will not work. This is ga-ga. So don't do it. + +@node Filtering New Groups +@subsection Filtering New Groups + A nice and portable way to control which new newsgroups should be subscribed (or ignored) is to put an @dfn{options} line at the start of the @file{.newsrc} file. Here's an example: @@ -610,49 +735,62 @@ @code{nnfolder}, @code{nnmbox}, and @code{nnmh}) subscribed. If you don't like that, just set this variable to @code{nil}. -@vindex gnus-check-new-newsgroups -If you are satisfied that you really never want to see any new groups, -you could set @code{gnus-check-new-newsgroups} to @code{nil}. This will -also save you some time at startup. Even if this variable is -@code{nil}, you can always subscribe to the new groups just by pressing -@kbd{U} in the group buffer (@pxref{Group Maintenance}). This variable -is @code{t} by default. - -Gnus normally determines whether a group is new or not by comparing the -list of groups from the active file(s) with the lists of subscribed and -dead groups. This isn't a particularly fast method. If -@code{gnus-check-new-newsgroups} is @code{ask-server}, Gnus will ask the -server for new groups since the last time. This is both faster & -cheaper. This also means that you can get rid of the list of killed -groups altogether, so you may set @code{gnus-save-killed-list} to -@code{nil}, which will save time both at startup, at exit, and all over. -Saves disk space, too. Why isn't this the default, then? -Unfortunately, not all servers support this command. - -I bet I know what you're thinking now: How do I find out whether my -server supports @code{ask-server}? No? Good, because I don't have a -fail-safe answer. I would suggest just setting this variable to -@code{ask-server} and see whether any new groups appear within the next -few days. If any do, then it works. If any don't, then it doesn't -work. I could write a function to make Gnus guess whether the server -supports @code{ask-server}, but it would just be a guess. So I won't. -You could @code{telnet} to the server and say @code{HELP} and see -whether it lists @samp{NEWGROUPS} among the commands it understands. If -it does, then it might work. (But there are servers that lists -@samp{NEWGROUPS} without supporting the function properly.) - -This variable can also be a list of select methods. If so, Gnus will -issue an @code{ask-server} command to each of the select methods, and -subscribe them (or not) using the normal methods. This might be handy -if you are monitoring a few servers for new groups. A side effect is -that startup will take much longer, so you can meditate while waiting. -Use the mantra ``dingnusdingnusdingnus'' to achieve permanent bliss. +New groups that match this regexp are subscribed using +@code{gnus-subscribe-options-newsgroup-method}. + + +@node Changing Servers +@section Changing Servers +@cindex changing servers + +Sometimes it is necessary to move from one @sc{nntp} server to another. +This happens very rarely, but perhaps you change jobs, or one server is +very flaky and you want to use another. + +Changing the server is pretty easy, right? You just change +@code{gnus-select-method} to point to the new server? + +@emph{Wrong!} + +Article numbers are not (in any way) kept synchronized between different +@sc{nntp} servers, and the only way Gnus keeps track of what articles +you have read is by keeping track of article numbers. So when you +change @code{gnus-select-method}, your @file{.newsrc} file becomes +worthless. + +Gnus provides a few functions to attempt to translate a @file{.newsrc} +file from one server to another. They all have one thing in +common---they take a looong time to run. You don't want to use these +functions more than absolutely necessary. + +@kindex M-x gnus-change-server +@findex gnus-change-server +If you have access to both servers, Gnus can request the headers for all +the articles you have read and compare @code{Message-ID}s and map the +article numbers of the read articles and article marks. The @kbd{M-x +gnus-change-server} command will do this for all your native groups. It +will prompt for the method you want to move to. + +@kindex M-x gnus-group-move-group-to-server +@findex gnus-group-move-group-to-server +You can also move individual groups with the @kbd{M-x +gnus-group-move-group-to-server} command. This is useful if you want to +move a (foreign) group from one server to another. + +@kindex M-x gnus-group-clear-data-on-native-groups +@findex gnus-group-clear-data-on-native-groups +If you don't have access to both the old and new server, all your marks +and read ranges have become worthless. You can use the @kbd{M-x +gnus-group-clear-data-on-native-groups} command to clear out all data +that you have on your native groups. Use with caution. @node Startup Files @section Startup Files @cindex startup files @cindex .newsrc +@cindex .newsrc.el +@cindex .newsrc.eld Now, you all know about the @file{.newsrc} file. All subscription information is traditionally stored in this file. @@ -681,11 +819,14 @@ If @code{gnus-save-killed-list} (default @code{t}) is @code{nil}, Gnus will not save the list of killed groups to the startup file. This will save both time (when starting and quitting) and space (on disk). It -will also means that Gnus has no record of what groups are new or old, +will also mean that Gnus has no record of what groups are new or old, so the automatic new groups subscription methods become meaningless. You should always set @code{gnus-check-new-newsgroups} to @code{nil} or @code{ask-server} if you set this variable to @code{nil} (@pxref{New -Groups}). +Groups}). This variable can also be a regular expression. If that's +the case, remove all groups that do not match this regexp before +saving. This can be useful in certain obscure situations that involve +several servers where not all servers support @code{ask-server}. @vindex gnus-startup-file The @code{gnus-startup-file} variable says where the startup files are. @@ -700,13 +841,23 @@ saving the @file{.newsrc.eld} file, and @code{gnus-save-standard-newsrc-hook} is called just before saving the @file{.newsrc} file. The latter two are commonly used to turn version -control on or off. Version control is off by default when saving the -startup files. +control on or off. Version control is on by default when saving the +startup files. If you want to turn backup creation off, say something like: + +@lisp +(defun turn-off-backup () + (set (make-local-variable 'backup-inhibited) t)) + +(add-hook 'gnus-save-quick-newsrc-hook 'turn-off-backup) +(add-hook 'gnus-save-standard-newsrc-hook 'turn-off-backup) +@end lisp @vindex gnus-init-file -When Gnus starts, it will read the @code{gnus-init-file} file, which is -@file{~/.gnus.el} by default. This is a normal Emacs Lisp file and can -be used to avoid cluttering your @file{.emacs} file with Gnus stuff. +When Gnus starts, it will read the @code{gnus-site-init-file} +(@file{.../site-lisp/gnus.el} by default) and @code{gnus-init-file} +(@file{~/.gnus.el} by default) files. These are normal Emacs Lisp files +and can be used to avoid cluttering your @file{.emacs} and +@file{site-init} files with Gnus stuff. @node Auto Save @@ -789,6 +940,9 @@ In any case, if you use @code{some} or @code{nil}, you should definitely kill all groups that you aren't interested in to speed things up. +Note that this variable also affects active file retrieval from +secondary select methods. + @node Startup Variables @section Startup Variables @@ -817,12 +971,23 @@ @item gnus-inhibit-startup-message @vindex gnus-inhibit-startup-message If non-@code{nil}, the startup message won't be displayed. That way, -your boss might not notice that you are reading news instead of doing -your job as easily. +your boss might not notice as easily that you are reading news instead +of doing your job. Note that this variable is used before +@file{.gnus.el} is loaded, so it should be set in @code{.emacs} instead. @item gnus-no-groups-message @vindex gnus-no-groups-message Message displayed by Gnus when no groups are available. + +@item gnus-play-startup-jingle +@vindex gnus-play-startup-jingle +If non-@code{nil}, play the Gnus jingle at startup. + +@item gnus-startup-jingle +@vindex gnus-startup-jingle +Jingle to be played if the above variable is non-@code{nil}. The +default is @samp{Tuxedomoon.Jingle4.au}. + @end table @@ -838,6 +1003,7 @@ * Group Buffer Format:: Information listed and how you can change it. * Group Maneuvering:: Commands for moving in the group buffer. * Selecting a Group:: Actually reading news. +* Group Data:: Changing the info for a group. * Subscription Commands:: Unsubscribing, killing, subscribing. * Group Levels:: Levels? What are those, then? * Group Score:: A mechanism for finding out what groups you like. @@ -856,7 +1022,6 @@ @node Group Buffer Format @section Group Buffer Format -@cindex group buffer format @menu * Group Line Specification:: Deciding how the group buffer is to look. @@ -867,6 +1032,7 @@ @node Group Line Specification @subsection Group Line Specification +@cindex group buffer format The default format of the group buffer is nice and dull, but you can make it as exciting and ugly as you feel like. @@ -892,8 +1058,7 @@ a @code{printf} specifications, for those of you who use (feh!) C. @xref{Formatting Variables}. -The default value that produced those lines above is -@samp{%M%S%5y: %(%g%)\n}. +@samp{%M%S%5y: %(%g%)\n} is the value that produced those lines above. There should always be a colon on the line; the cursor always moves to the colon after performing an operation. Nothing else is required---not @@ -910,7 +1075,7 @@ @table @samp @item M -Only marked articles. +An asterisk if the group only has marked articles. @item S Whether the group is subscribed. @@ -931,7 +1096,8 @@ Number of read articles. @item t -Total number of articles. +Estimated total number of articles. (This is really @var{max-number} +minus @var{min-number} plus 1.) @item y Number of unread, unticked, non-dormant articles. @@ -971,30 +1137,43 @@ @vindex gnus-group-uncollapsed-levels Short (collapsed) group name. The @code{gnus-group-uncollapsed-levels} variable says how many levels to leave at the end of the group name. -The default is @code{1}. +The default is 1---this will mean that group names like +@samp{gnu.emacs.gnus} will be shortened to @samp{g.emacs.gnus}. + +@item m +@vindex gnus-new-mail-mark +@cindex % +@samp{%} (@code{gnus-new-mail-mark}) if there has arrived new mail to +the group lately. + +@item d +A string that says when you last read the group (@pxref{Group +Timestamp}). @item u User defined specifier. The next character in the format string should be a letter. @sc{gnus} will call the function @code{gnus-user-format-function-}@samp{X}, where @samp{X} is the letter -following @samp{%u}. The function will be passed the current headers as -argument. The function should return a string, which will be inserted -into the buffer just like information from any other specifier. +following @samp{%u}. The function will be passed a single dummy +paratere as argument. The function should return a string, which will +be inserted into the buffer just like information from any other +specifier. @end table @cindex * All the ``number-of'' specs will be filled with an asterisk (@samp{*}) if no info is available---for instance, if it is a non-activated foreign -group, or a bogus (or semi-bogus) native group. +group, or a bogus native group. @node Group Modeline Specification @subsection Group Modeline Specification +@cindex group modeline @vindex gnus-group-mode-line-format The mode line can be changed by setting -(@code{gnus-group-mode-line-format}). It doesn't understand that many -format specifiers: +@code{gnus-group-mode-line-format} (@pxref{Formatting Variables}). It +doesn't understand that many format specifiers: @table @samp @item S @@ -1006,6 +1185,8 @@ @node Group Highlighting @subsection Group Highlighting +@cindex highlighting +@cindex group highlighting @vindex gnus-group-highlight Highlighting in the group buffer is controlled by the @@ -1018,17 +1199,16 @@ @lisp (setq gnus-group-highlight - `(((> unread 200) . - ,(custom-face-lookup "Red" nil nil t nil nil)) - ((and (< level 3) (zerop unread)) . - ,(custom-face-lookup "SeaGreen" nil nil t nil nil)) - ((< level 3) . - ,(custom-face-lookup "SpringGreen" nil nil t nil nil)) - ((zerop unread) . - ,(custom-face-lookup "SteelBlue" nil nil t nil nil)) - (t . - ,(custom-face-lookup "SkyBlue" nil nil t nil nil)) - )) + `(((> unread 200) . + ,(custom-face-lookup "Red" nil nil t nil nil)) + ((and (< level 3) (zerop unread)) . + ,(custom-face-lookup "SeaGreen" nil nil t nil nil)) + ((< level 3) . + ,(custom-face-lookup "SpringGreen" nil nil t nil nil)) + ((zerop unread) . + ,(custom-face-lookup "SteelBlue" nil nil t nil nil)) + (t . + ,(custom-face-lookup "SkyBlue" nil nil t nil nil)))) @end lisp Variables that are dynamically bound when the forms are evaluated @@ -1049,6 +1229,9 @@ The score of the group. @item ticked The number of ticked articles in the group. +@item total +The total number of articles in the group. Or rather, MAX-NUMBER minus +MIN-NUMBER. @item topic When using the topic minor mode, this variable is bound to the current topic being inserted. @@ -1081,12 +1264,11 @@ (@code{gnus-group-next-unread-group}). @item p - @itemx DEL @kindex DEL (Group) @kindex p (Group) @findex gnus-group-prev-unread-group -Go to the previous group group that has unread articles +Go to the previous group that has unread articles (@code{gnus-group-prev-unread-group}). @item N @@ -1102,13 +1284,13 @@ @item M-p @kindex M-p (Group) @findex gnus-group-next-unread-group-same-level -Go to the next unread group on the same level (or lower) +Go to the next unread group on the same (or lower) level (@code{gnus-group-next-unread-group-same-level}). @item M-n @kindex M-n (Group) @findex gnus-group-prev-unread-group-same-level -Go to the previous unread group on the same level (or lower) +Go to the previous unread group on the same (or lower) level (@code{gnus-group-prev-unread-group-same-level}). @end table @@ -1156,10 +1338,10 @@ first unread article (@code{gnus-group-read-group}). If there are no unread articles in the group, or if you give a non-numerical prefix to this command, Gnus will offer to fetch all the old articles in this -group from the server. If you give a numerical prefix @var{N}, Gnus -will fetch @var{N} number of articles. If @var{N} is positive, fetch -the @var{N} newest articles, if @var{N} is negative, fetch the -@var{abs(N)} oldest articles. +group from the server. If you give a numerical prefix @var{N}, @var{N} +determines the number of articles Gnus will fetch. If @var{N} is +positive, Gnus fetches the @var{N} newest articles, if @var{N} is +negative, Gnus fetches the @var{abs(N)} oldest articles. @item RET @kindex RET (Group) @@ -1174,47 +1356,46 @@ @kindex M-RET (Group) @findex gnus-group-quick-select-group This does the same as the command above, but tries to do it with the -minimum amount off fuzz (@code{gnus-group-quick-select-group}). No +minimum amount of fuzz (@code{gnus-group-quick-select-group}). No scoring/killing will be performed, there will be no highlights and no expunging. This might be useful if you're in a real hurry and have to -enter some humongous group. +enter some humongous group. If you give a 0 prefix to this command +(i.e., @kbd{0 M-RET}), Gnus won't even generate the summary buffer. +This might be useful if you want to toggle threading before entering the +group. @item M-SPACE -@kindex M-RET (Group) +@kindex M-SPACE (Group) @findex gnus-group-visible-select-group -This is yet one more command that does the same as the one above, but -this one does it without expunging and hiding dormants -(@code{gnus-group-visible-select-group}). - -@item c -@kindex c (Group) -@findex gnus-group-catchup-current -@vindex gnus-group-catchup-group-hook -Mark all unticked articles in this group as read -(@code{gnus-group-catchup-current}). -@code{gnus-group-catchup-group-hook} is when catching up a group from -the group buffer. - -@item C -@kindex C (Group) -@findex gnus-group-catchup-current-all -Mark all articles in this group, even the ticked ones, as read -(@code{gnus-group-catchup-current-all}). +This is yet one more command that does the same as the @kbd{RET} +command, but this one does it without expunging and hiding dormants +(@code{gnus-group-visible-select-group}). + +@item M-C-RET +@kindex M-C-RET (Group) +@findex gnus-group-select-group-ephemerally +Finally, this command selects the current group ephemerally without +doing any processing of its contents +(@code{gnus-group-select-group-ephemerally}). Even threading has been +turned off. Everything you do in the group after selecting it in this +manner will have no permanent effects. + @end table @vindex gnus-large-newsgroup The @code{gnus-large-newsgroup} variable says what Gnus should consider to be a big group. This is 200 by default. If the group has more -unread articles than this, Gnus will query the user before entering the -group. The user can then specify how many articles should be fetched -from the server. If the user specifies a negative number (@code{-n}), -the @code{n} oldest articles will be fetched. If it is positive, the -@code{n} articles that have arrived most recently will be fetched. +(unread and/or ticked) articles than this, Gnus will query the user +before entering the group. The user can then specify how many articles +should be fetched from the server. If the user specifies a negative +number (@code{-n}), the @code{n} oldest articles will be fetched. If it +is positive, the @code{n} articles that have arrived most recently will +be fetched. @vindex gnus-select-group-hook @vindex gnus-auto-select-first @code{gnus-auto-select-first} control whether any articles are selected -automatically when entering a group. +automatically when entering a group with the @kbd{SPACE} command. @table @code @@ -1238,7 +1419,7 @@ @node Subscription Commands @section Subscription Commands -@cindex subscribing +@cindex subscription @table @kbd @@ -1297,9 +1478,9 @@ @findex gnus-group-kill-level Kill all groups on a certain level (@code{gnus-group-kill-level}). These groups can't be yanked back after killing, so this command should -be used with some caution. The only thing where this command comes in +be used with some caution. The only time where this command comes in really handy is when you have a @file{.newsrc} with lots of unsubscribed -groups that you want to get rid off. @kbd{S C-k} on level @code{7} will +groups that you want to get rid off. @kbd{S C-k} on level 7 will kill off all unsubscribed groups that do not have message numbers in the @file{.newsrc} file. @@ -1308,9 +1489,47 @@ Also @pxref{Group Levels}. +@node Group Data +@section Group Data + +@table @kbd + +@item c +@kindex c (Group) +@findex gnus-group-catchup-current +@vindex gnus-group-catchup-group-hook +Mark all unticked articles in this group as read +(@code{gnus-group-catchup-current}). +@code{gnus-group-catchup-group-hook} is called when catching up a group from +the group buffer. + +@item C +@kindex C (Group) +@findex gnus-group-catchup-current-all +Mark all articles in this group, even the ticked ones, as read +(@code{gnus-group-catchup-current-all}). + +@item M-c +@kindex M-c (Group) +@findex gnus-group-clear-data +Clear the data from the current group---nix out marks and the list of +read articles (@code{gnus-group-clear-data}). + +@item M-x gnus-group-clear-data-on-native-groups +@kindex M-x gnus-group-clear-data-on-native-groups +@findex gnus-group-clear-data-on-native-groups +If you have switched from one @sc{nntp} server to another, all your marks +and read ranges have become worthless. You can use this command to +clear out all data that you have on your native groups. Use with +caution. + +@end table + + @node Group Levels @section Group Levels @cindex group level +@cindex level All groups have a level of @dfn{subscribedness}. For instance, if a group is on level 2, it is more subscribed than a group on level 5. You @@ -1347,7 +1566,7 @@ for reasons of efficiency. It is recommended that you keep all your mail groups (if any) on quite -low levels (eg. 1 or 2). +low levels (e.g. 1 or 2). If you want to play with the level variables, you should show some care. Set them once, and don't touch them ever again. Better yet, don't touch @@ -1389,7 +1608,7 @@ Gnus will normally just activate groups that are on level @code{gnus-activate-level} or less. If you don't want to activate unsubscribed groups, for instance, you might set this variable to -@code{5}. +5. The default is 6. @node Group Score @@ -1407,7 +1626,7 @@ the level and the score is called the @dfn{rank} of the group. A group that is on level 4 and has a score of 1 has a higher rank than a group on level 5 that has a score of 300. (The level is the most significant -part and the score is the least significant part.) +part and the score is the least significant part.)) @findex gnus-summary-bubble-group If you want groups you read often to get higher scores than groups you @@ -1483,16 +1702,20 @@ @node Foreign Groups @section Foreign Groups - -Here are some group mode commands for making and editing general foreign +@cindex foreign groups + +Below are some group mode commands for making and editing general foreign groups, as well as commands to ease the creation of a few -special-purpose groups: +special-purpose groups. All these commands insert the newly created +groups under point---@code{gnus-subscribe-newsgroup-method} is not +consulted. @table @kbd @item G m @kindex G m (Group) @findex gnus-group-make-group +@cindex making groups Make a new group (@code{gnus-group-make-group}). Gnus will prompt you for a name, a method and possibly an @dfn{address}. For an easier way to subscribe to @sc{nntp} groups, @pxref{Browse Foreign Server}. @@ -1500,14 +1723,22 @@ @item G r @kindex G r (Group) @findex gnus-group-rename-group +@cindex renaming groups Rename the current group to something else (@code{gnus-group-rename-group}). This is legal only on some groups---mail groups mostly. This command might very well be quite slow on some backends. +@item G c +@kindex G c (Group) +@cindex customizing +@findex gnus-group-customize +Customize the group parameters (@code{gnus-group-customize}). + @item G e @kindex G e (Group) @findex gnus-group-edit-group-method +@cindex renaming groups Enter a buffer where you can edit the select method of the current group (@code{gnus-group-edit-group-method}). @@ -1526,16 +1757,20 @@ @item G d @kindex G d (Group) @findex gnus-group-make-directory-group -Make a directory group. You will be prompted for a directory name -(@code{gnus-group-make-directory-group}). +@cindex nndir +Make a directory group (@pxref{Directory Groups}). You will be prompted +for a directory name (@code{gnus-group-make-directory-group}). @item G h @kindex G h (Group) +@cindex help group @findex gnus-group-make-help-group Make the Gnus help group (@code{gnus-group-make-help-group}). @item G a @kindex G a (Group) +@cindex (ding) archive +@cindex archive group @findex gnus-group-make-archive-group @vindex gnus-group-archive-directory @vindex gnus-group-recent-archive-directory @@ -1547,28 +1782,46 @@ @item G k @kindex G k (Group) @findex gnus-group-make-kiboze-group +@cindex nnkiboze Make a kiboze group. You will be prompted for a name, for a regexp to match groups to be ``included'' in the kiboze group, and a series of strings to match on headers (@code{gnus-group-make-kiboze-group}). -@xref{Kibozed Groups} +@xref{Kibozed Groups}. @item G D @kindex G D (Group) @findex gnus-group-enter-directory +@cindex nneething Read an arbitrary directory as if with were a newsgroup with the @code{nneething} backend (@code{gnus-group-enter-directory}). +@xref{Anything Groups}. @item G f @kindex G f (Group) @findex gnus-group-make-doc-group @cindex ClariNet Briefs +@cindex nndoc Make a group based on some file or other (@code{gnus-group-make-doc-group}). If you give a prefix to this command, you will be prompted for a file name and a file type. Currently supported types are @code{babyl}, @code{mbox}, @code{digest}, @code{mmdf}, @code{news}, @code{rnews}, @code{clari-briefs}, and @code{forward}. If you run this command without a prefix, Gnus will -guess at the file type. +guess at the file type. @xref{Document Groups}. + +@item G w +@kindex G w (Group) +@findex gnus-group-make-web-group +@cindex DejaNews +@cindex Alta Vista +@cindex InReference +@cindex nnweb +Make an ephemeral group based on a web search +(@code{gnus-group-make-web-group}). If you give a prefix to this +command, make a solid group instead. You will be prompted for the +search engine type and the search string. Legal search engine types +include @code{dejanews}, @code{altavista} and @code{reference}. +@xref{Web Searches}. @item G DEL @kindex G DEL (Group) @@ -1583,7 +1836,7 @@ @kindex G V (Group) @findex gnus-group-make-empty-virtual Make a new, fresh, empty @code{nnvirtual} group -(@code{gnus-group-make-empty-virtual}). +(@code{gnus-group-make-empty-virtual}). @xref{Virtual Groups}. @item G v @kindex G v (Group) @@ -1596,7 +1849,7 @@ methods. @vindex gnus-activate-foreign-newsgroups -If the @code{gnus-activate-foreign-newsgroups} is a positive number, +If @code{gnus-activate-foreign-newsgroups} is a positive number, Gnus will check all foreign groups with this level or lower at startup. This might take quite a while, especially if you subscribe to lots of groups from different @sc{nntp} servers. @@ -1606,27 +1859,6 @@ @section Group Parameters @cindex group parameters -Gnus stores all information on a group in a list that is usually known -as the @dfn{group info}. This list has from three to six elements. -Here's an example info. - -@lisp -("nnml:mail.ding" 3 ((1 . 232) 244 (256 . 270)) ((tick 246 249)) - (nnml "private") ((to-address . "ding@@ifi.uio.no"))) -@end lisp - -The first element is the @dfn{group name}, as Gnus knows the group, -anyway. The second element is the @dfn{subscription level}, which -normally is a small integer. The third element is a list of ranges of -read articles. The fourth element is a list of lists of article marks -of various kinds. The fifth element is the select method (or virtual -server, if you like). The sixth element is a list of @dfn{group -parameters}, which is what this section is about. - -Any of the last three elements may be missing if they are not required. -In fact, the vast majority of groups will normally only have the first -three elements, which saves quite a lot of cons cells. - The group parameters store information local to a particular group: @table @code @@ -1666,20 +1898,36 @@ @item to-group @cindex to-group -If the group parameter list contains an element like @code{(to-group -. "some.group.name")}, all posts will be sent to that group. +Elements like @code{(to-group . "some.group.name")} means that all +posts in that group will be sent to @code{some.group.name}. + +@item newsgroup +@cindex newsgroup +If this symbol is present in the group parameter list, Gnus will treat +all responses as if they were responses to news articles. This can be +useful if you have a mail group that's really a mirror of a news group. + +@item gcc-self +@cindex gcc-self +If this symbol is present in the group parameter list and set to +@code{t}, new composed messages will be @code{Gcc}'d to the current +group. If it is present and set to @code{none}, no @code{Gcc:} header +will be generated, if it is present and a string, this string will be +inserted literally as a @code{gcc} header (this symbol takes precedence over +any default @code{Gcc} rules as described later). @item auto-expire @cindex auto-expire -If this symbol is present in the group parameter list, all articles that -are read will be marked as expirable. For an alternative approach, -@pxref{Expiring Mail}. +If the group parameter has an element that looks like @code{(auto-expire +. t)}, , all articles that are read will be marked as expirable. For an +alternative approach, @pxref{Expiring Mail}. @item total-expire @cindex total-expire -If this symbol is present, all read articles will be put through the +If the group parameter has an element that looks like +@code{(total-expire . t)}, all read articles will be put through the expiry process, even if they are not marked as expirable. Use with -caution. +caution. @item expiry-wait @cindex expiry-wait @@ -1691,41 +1939,61 @@ the symbols @code{never} or @code{immediate}. @item score-file +@cindex score file group parameter Elements that look like @code{(score-file . "file")} will make -@samp{file} into the current score file for the group in question. This +@file{file} into the current score file for the group in question. This means that all score commands you issue will end up in that file. +@item adapt-file +@cindex adapt file group parameter +Elements that look like @code{(adapt-file . "file")} will make +@file{file} into the current adaptive file for the group in question. +All adaptive score entries will be put into this file. + @item admin-address 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. +@item display +Elements that look like @code{(display . MODE)} says which articles to +display on entering the group. Legal values are: + +@table @code +@item all +Display all articles, both read and unread. + +@item default +Display the default visible articles, which normally includes unread and +ticked articles. +@end table + @item comment -This parameter allows you to enter a arbitrary comment on the group. +Elements that look like @code{(comment . "This is a comment")} +are arbitrary comments on the group. They are currently ignored by +Gnus, but provide a place for you to store information on particular +groups. @item @var{(variable form)} You can use the group parameters to set variables local to the group you -are entering. Say you want to turn threading off in -@samp{news.answers}. You'd then put @code{(gnus-show-threads nil)} in -the group parameters of that group. @code{gnus-show-threads} will be -made into a local variable in the summary buffer you enter, and the form -@code{nil} will be @code{eval}ed there. +are entering. If you want to turn threading off in @samp{news.answers}, +you could put @code{(gnus-show-threads nil)} in the group parameters of +that group. @code{gnus-show-threads} will be made into a local variable +in the summary buffer you enter, and the form @code{nil} will be +@code{eval}ed there. 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 the group -@samp{alt.binaries.pictures.furniture}, you could put something like -@code{(dummy-variable (ding))} in the parameters of that group. -@code{dummy-variable} will be set to the result of the @code{(ding)} -form, but who cares? - -@end table - -If you want to change the group info you can use the @kbd{G E} command -to enter a buffer where you can edit it. - -You usually don't want to edit the entire group info, so you'd be better -off using the @kbd{G p} command to just edit the group parameters. +If you want to hear a beep when you enter a group, you could put +something like @code{(dummy-variable (ding))} in the parameters of that +group. @code{dummy-variable} will be set to the result of the +@code{(ding)} form, but who cares? + +@end table + +Use the @kbd{G p} command to edit group parameters of a group. + +Also @pxref{Topic Parameters}. @node Listing Groups @@ -1744,7 +2012,9 @@ List all groups that have unread articles (@code{gnus-group-list-groups}). If the numeric prefix is used, this command will list only groups of level ARG and lower. By default, it -only lists groups of level five or lower (i.e., just subscribed groups). +only lists groups of level five (i. e., +@code{gnus-group-default-list-level}) or lower (i.e., just subscribed +groups). @item L @itemx A u @@ -1794,8 +2064,10 @@ List absolutely all groups that are in the active file(s) of the server(s) you are connected to (@code{gnus-group-list-active}). This might very well take quite a while. It might actually be a better idea -to do a @kbd{A m} to list all matching, and just give @samp{.} as the -thing to match on. +to do a @kbd{A M} to list all matching, and just give @samp{.} as the +thing to match on. Also note that this command may list group that +don't exist (yet)---these will be listed as if they are killed groups. +Take the output with some grains of salt. @item A a @kindex A a (Group) @@ -1843,6 +2115,10 @@ @findex gnus-group-sort-by-alphabet Sort the group names alphabetically. This is the default. +@item gnus-group-sort-by-real-name +@findex gnus-group-sort-by-real-name +Sort the group alphabetically on the real (unprefixed) group names. + @item gnus-group-sort-by-level @findex gnus-group-sort-by-level Sort by group level. @@ -1862,7 +2138,7 @@ @item gnus-group-sort-by-method @findex gnus-group-sort-by-method -Sort by alphabetically on the select method. +Sort alphabetically on the select method. @end table @@ -1903,7 +2179,7 @@ @item G S r @kindex G S r (Group) @findex gnus-group-sort-groups-by-rank -Sort the group buffer by group level +Sort the group buffer by group rank (@code{gnus-group-sort-groups-by-rank}). @item G S m @@ -1916,6 +2192,48 @@ When given a prefix, all these commands will sort in reverse order. +You can also sort a subset of the groups: + +@table @kbd +@item G P a +@kindex G P a (Group) +@findex gnus-group-sort-selected-groups-by-alphabet +Sort the process/prefixed groups in the group buffer alphabetically by +group name (@code{gnus-group-sort-selected-groups-by-alphabet}). + +@item G P u +@kindex G P u (Group) +@findex gnus-group-sort-selected-groups-by-unread +Sort the process/prefixed groups in the group buffer by the number of +unread articles (@code{gnus-group-sort-selected-groups-by-unread}). + +@item G P l +@kindex G P l (Group) +@findex gnus-group-sort-selected-groups-by-level +Sort the process/prefixed groups in the group buffer by group level +(@code{gnus-group-sort-selected-groups-by-level}). + +@item G P v +@kindex G P v (Group) +@findex gnus-group-sort-selected-groups-by-score +Sort the process/prefixed groups in the group buffer by group score +(@code{gnus-group-sort-selected-groups-by-score}). + +@item G P r +@kindex G P r (Group) +@findex gnus-group-sort-selected-groups-by-rank +Sort the process/prefixed groups in the group buffer by group rank +(@code{gnus-group-sort-selected-groups-by-rank}). + +@item G P m +@kindex G P m (Group) +@findex gnus-group-sort-selected-groups-by-method +Sort the process/prefixed groups in the group buffer alphabetically by +backend name (@code{gnus-group-sort-selected-groups-by-method}). + +@end table + + @node Group Maintenance @section Group Maintenance @@ -1966,16 +2284,8 @@ @findex gnus-browse-mode A new buffer with a list of available groups will appear. This buffer -will be use the @code{gnus-browse-mode}. This buffer looks a bit -(well, a lot) like a normal group buffer, but with one major difference -- you can't enter any of the groups. If you want to read any of the -news available on that server, you have to subscribe to the groups you -think may be interesting, and then you have to exit this buffer. The -new groups will be added to the group buffer, and then you can read them -as you would any other group. - -Future versions of Gnus may possibly permit reading groups straight from -the browse buffer. +will be use the @code{gnus-browse-mode}. This buffer looks a bit (well, +a lot) like a normal group buffer. Here's a list of keystrokes available in the browse mode: @@ -2044,7 +2354,8 @@ @item Q @kindex Q (Group) @findex gnus-group-quit -Quit Gnus without saving any startup files (@code{gnus-group-quit}). +Quit Gnus without saving the @file{.newsrc} files (@code{gnus-group-quit}). +The dribble file will be saved, though (@pxref{Auto Save}). @end table @vindex gnus-exit-gnus-hook @@ -2063,7 +2374,7 @@ Note: @quotation -Miss Lisa Cannifax, while sitting in English class, feels her feet go +Miss Lisa Cannifax, while sitting in English class, felt her feet go numbly heavy and herself fall into a hazy trance as the boy sitting behind her drew repeated lines with his pencil across the back of her plastic chair. @@ -2081,6 +2392,21 @@ even group the Emacs sex groups as a sub-topic to either the Emacs groups or the sex groups---or both! Go wild! +Here's an example: + +@example +Gnus + Emacs -- I wuw it! + 3: comp.emacs + 2: alt.religion.emacs + Naughty Emacs + 452: alt.sex.emacs + 0: comp.talk.emacs.recovery + Misc + 8: comp.binaries.fractals + 13: comp.sources.unix +@end example + @findex gnus-topic-mode @kindex t (Group) To get this @emph{fab} functionality you simply turn on (ooh!) the @@ -2103,7 +2429,9 @@ @menu * Topic Variables:: How to customize the topics the Lisp Way. * Topic Commands:: Interactive E-Z commands. +* Topic Sorting:: Sorting each topic individually. * Topic Topology:: A map of the world. +* Topic Parameters:: Parameters that apply to all groups in a topic. @end menu @@ -2116,8 +2444,8 @@ @vindex gnus-topic-line-format The topic lines themselves are created according to the -@code{gnus-topic-line-format} variable. @xref{Formatting Variables}. -Elements allowed are: +@code{gnus-topic-line-format} variable (@pxref{Formatting Variables}). +Legal elements are: @table @samp @item i @@ -2139,11 +2467,15 @@ @vindex gnus-topic-indent-level Each sub-topic (and the groups in the sub-topics) will be indented with @code{gnus-topic-indent-level} times the topic level number of spaces. -The default is @code{2}. +The default is 2. @vindex gnus-topic-mode-hook @code{gnus-topic-mode-hook} is called in topic minor mode buffers. +@vindex gnus-topic-display-empty-topics +The @code{gnus-topic-display-empty-topics} says whether to display even +topics that have no unread articles in them. The default is @code{t}. + @node Topic Commands @subsection Topic Commands @@ -2156,58 +2488,58 @@ @table @kbd @item T n -@kindex T n (Group) +@kindex T n (Topic) @findex gnus-topic-create-topic Prompt for a new topic name and create it (@code{gnus-topic-create-topic}). @item T m -@kindex T m (Group) +@kindex T m (Topic) @findex gnus-topic-move-group Move the current group to some other topic -(@code{gnus-topic-move-group}). This command understands the -process/prefix convention (@pxref{Process/Prefix}). +(@code{gnus-topic-move-group}). This command uses the process/prefix +convention (@pxref{Process/Prefix}). @item T c -@kindex T c (Group) +@kindex T c (Topic) @findex gnus-topic-copy-group Copy the current group to some other topic -(@code{gnus-topic-copy-group}). This command understands the -process/prefix convention (@pxref{Process/Prefix}). +(@code{gnus-topic-copy-group}). This command uses the process/prefix +convention (@pxref{Process/Prefix}). @item T D -@kindex T D (Group) +@kindex T D (Topic) @findex gnus-topic-remove-group Remove a group from the current topic (@code{gnus-topic-remove-group}). -This command understands the process/prefix convention +This command uses the process/prefix convention (@pxref{Process/Prefix}). @item T M -@kindex T M (Group) +@kindex T M (Topic) @findex gnus-topic-move-matching Move all groups that match some regular expression to a topic (@code{gnus-topic-move-matching}). @item T C -@kindex T C (Group) +@kindex T C (Topic) @findex gnus-topic-copy-matching Copy all groups that match some regular expression to a topic (@code{gnus-topic-copy-matching}). @item T # -@kindex T # (Group) +@kindex T # (Topic) @findex gnus-topic-mark-topic Mark all groups in the current topic with the process mark (@code{gnus-topic-mark-topic}). @item T M-# -@kindex T M-# (Group) +@kindex T M-# (Topic) @findex gnus-topic-unmark-topic Remove the process mark from all groups in the current topic (@code{gnus-topic-unmark-topic}). @item RET -@kindex RET (Group) +@kindex RET (Topic) @findex gnus-topic-select-group @itemx SPACE Either select a group or fold a topic (@code{gnus-topic-select-group}). @@ -2218,40 +2550,101 @@ prefix, group on that level (and lower) will be displayed. @item T TAB -@kindex T TAB (Group) +@kindex T TAB (Topic) @findex gnus-topic-indent ``Indent'' the current topic so that it becomes a sub-topic of the previous topic (@code{gnus-topic-indent}). If given a prefix, ``un-indent'' the topic instead. @item C-k -@kindex C-k (Group) +@kindex C-k (Topic) @findex gnus-topic-kill-group -Kill a group or topic (@code{gnus-topic-kill-group}). +Kill a group or topic (@code{gnus-topic-kill-group}). All groups in the +topic will be removed along with the topic. @item C-y -@kindex C-y (Group) +@kindex C-y (Topic) @findex gnus-topic-yank-group -Yank the previously killed group or topic (@code{gnus-topic-yank-group}). -Note that all topics will be yanked before all groups. +Yank the previously killed group or topic +(@code{gnus-topic-yank-group}). Note that all topics will be yanked +before all groups. @item T r -@kindex T r (Group) +@kindex T r (Topic) @findex gnus-topic-rename Rename a topic (@code{gnus-topic-rename}). @item T DEL -@kindex T DEL (Group) +@kindex T DEL (Topic) @findex gnus-topic-delete Delete an empty topic (@code{gnus-topic-delete}). @item A T -@kindex A T (Group) +@kindex A T (Topic) @findex gnus-topic-list-active List all groups that Gnus knows about in a topics-ified way (@code{gnus-topic-list-active}). -@end table +@item G p +@kindex G p (Topic) +@findex gnus-topic-edit-parameters +@cindex group parameters +@cindex topic parameters +@cindex parameters +Edit the topic parameters (@code{gnus-topic-edit-parameters}). +@xref{Topic Parameters}. + +@end table + + +@node Topic Sorting +@subsection Topic Sorting +@cindex topic sorting + +You can sort the groups in each topic individually with the following +commands: + + +@table @kbd +@item T S a +@kindex T S a (Topic) +@findex gnus-topic-sort-groups-by-alphabet +Sort the current topic alphabetically by group name +(@code{gnus-topic-sort-groups-by-alphabet}). + +@item T S u +@kindex T S u (Topic) +@findex gnus-topic-sort-groups-by-unread +Sort the current topic by the number of unread articles +(@code{gnus-topic-sort-groups-by-unread}). + +@item T S l +@kindex T S l (Topic) +@findex gnus-topic-sort-groups-by-level +Sort the current topic by group level +(@code{gnus-topic-sort-groups-by-level}). + +@item T S v +@kindex T S v (Topic) +@findex gnus-topic-sort-groups-by-score +Sort the current topic by group score +(@code{gnus-topic-sort-groups-by-score}). + +@item T S r +@kindex T S r (Topic) +@findex gnus-topic-sort-groups-by-rank +Sort the current topic by group rank +(@code{gnus-topic-sort-groups-by-rank}). + +@item T S m +@kindex T S m (Topic) +@findex gnus-topic-sort-groups-by-method +Sort the current topic alphabetically by backend name +(@code{gnus-topic-sort-groups-by-method}). + +@end table + +@xref{Sorting Groups} for more information about group sorting. @node Topic Topology @@ -2264,19 +2657,20 @@ @example Gnus Emacs -- I wuw it! - 3: comp.emacs - 2: alt.religion.emacs + 3: comp.emacs + 2: alt.religion.emacs Naughty Emacs 452: alt.sex.emacs 0: comp.talk.emacs.recovery Misc - 8: comp.binaries.fractals - 13: comp.sources.unix + 8: comp.binaries.fractals + 13: comp.sources.unix @end example -So, here we have one top-level topic, two topics under that, and one -sub-topic under one of the sub-topics. (There is always just one (1) -top-level topic). This topology can be expressed as follows: +So, here we have one top-level topic (@samp{Gnus}), two topics under +that, and one sub-topic under one of the sub-topics. (There is always +just one (1) top-level topic). This topology can be expressed as +follows: @lisp (("Gnus" visible) @@ -2297,12 +2691,64 @@ allowed---@code{visible} and @code{invisible}. +@node Topic Parameters +@subsection Topic Parameters +@cindex topic parameters + +All groups in a topic will inherit group parameters from the parent (and +ancestor) topic parameters. All legal group parameters are legal topic +parameters (@pxref{Group Parameters}). + +Group parameters (of course) override topic parameters, and topic +parameters in sub-topics override topic parameters in super-topics. You +know. Normal inheritance rules. (@dfn{Rules} is here a noun, not a +verb, although you may feel free to disagree with me here.) + +@example +Gnus + Emacs + 3: comp.emacs + 2: alt.religion.emacs + 452: alt.sex.emacs + Relief + 452: alt.sex.emacs + 0: comp.talk.emacs.recovery + Misc + 8: comp.binaries.fractals + 13: comp.sources.unix + 452: alt.sex.emacs +@end example + +The @samp{Emacs} topic has the topic parameter @code{(score-file +. "emacs.SCORE")}; the @samp{Relief} topic has the topic parameter +@code{(score-file . "relief.SCORE")}; and the @samp{Misc} topic has the +topic parameter @code{(score-file . "emacs.SCORE")}. In addition, +@samp{alt.religion.emacs} has the group parameter @code{(score-file +. "religion.SCORE")}. + +Now, when you enter @samp{alt.sex.emacs} in the @samp{Relief} topic, you +will get the @file{relief.SCORE} home score file. If you enter the same +group in the @samp{Emacs} topic, you'll get the @file{emacs.SCORE} home +score file. If you enter the group @samp{alt.religion.emacs}, you'll +get the @file{religion.SCORE} home score file. + +This seems rather simple and self-evident, doesn't it? Well, yes. But +there are some problems, especially with the @code{total-expiry} +parameter. Say you have a mail group in two topics; one with +@code{total-expiry} and one without. What happens when you do @kbd{M-x +gnus-expire-all-expirable-groups}? Gnus has no way of telling which one +of these topics you mean to expire articles from, so anything may +happen. In fact, I hereby declare that it is @dfn{undefined} what +happens. You just have to be careful if you do stuff like that. + + @node Misc Group Stuff @section Misc Group Stuff @menu * Scanning New Messages:: Asking Gnus to see whether new messages have arrived. * Group Information:: Information and help on groups and Gnus. +* Group Timestamp:: Making Gnus keep track of when you last read a group. * File Commands:: Reading and writing the Gnus files. @end menu @@ -2311,8 +2757,8 @@ @item ^ @kindex ^ (Group) @findex gnus-group-enter-server-mode -Enter the server buffer (@code{gnus-group-enter-server-mode}). @xref{The -Server Buffer}. +Enter the server buffer (@code{gnus-group-enter-server-mode}). +@xref{The Server Buffer}. @item a @kindex a (Group) @@ -2371,10 +2817,9 @@ @findex gnus-group-get-new-news-this-group @vindex gnus-goto-next-group-when-activating Check whether new articles have arrived in the current group -(@code{gnus-group-get-new-news-this-group}). The -@code{gnus-goto-next-group-when-activating} variable controls whether -this command is to move point to the next group or not. It is @code{t} -by default. +(@code{gnus-group-get-new-news-this-group}). +@code{gnus-goto-next-group-when-activating} says whether this command is +to move point to the next group or not. It is @code{t} by default. @findex gnus-activate-all-groups @cindex activating groups @@ -2386,7 +2831,9 @@ @kindex R (Group) @cindex restarting @findex gnus-group-restart -Restart Gnus (@code{gnus-group-restart}). +Restart Gnus (@code{gnus-group-restart}). This saves the @file{.newsrc} +file(s), closes the connection to all servers, clears up all run-time +Gnus variables, and then starts Gnus all over again. @end table @@ -2405,18 +2852,28 @@ @table @kbd -@item M-f -@kindex M-f (Group) + +@item H f +@kindex H f (Group) @findex gnus-group-fetch-faq +@vindex gnus-group-faq-directory @cindex FAQ @cindex ange-ftp Try to fetch the FAQ for the current group (@code{gnus-group-fetch-faq}). Gnus will try to get the FAQ from @code{gnus-group-faq-directory}, which is usually a directory on a -remote machine. @code{ange-ftp} will be used for fetching the file. - -@item D -@kindex D (Group) +remote machine. This variable can also be a list of directories. In +that case, giving a prefix to this command will allow you to choose +between the various sites. @code{ange-ftp} (or @code{efs}) will be used +for fetching the file. + +If fetching from the first site is unsuccessful, Gnus will attempt to go +through @code{gnus-group-faq-directory} and try to open them one by one. + +@item H d +@itemx C-c C-d +@kindex H d (Group) +@kindex C-c C-d (Group) @cindex describing groups @cindex group description @findex gnus-group-describe-group @@ -2449,6 +2906,46 @@ @end table +@node Group Timestamp +@subsection Group Timestamp +@cindex timestamps +@cindex group timestamps + +It can be convenient to let Gnus keep track of when you last read a +group. To set the ball rolling, you should add +@code{gnus-group-set-timestamp} to @code{gnus-select-group-hook}: + +@lisp +(add-hook 'gnus-select-group-hook 'gnus-group-set-timestamp) +@end lisp + +After doing this, each time you enter a group, it'll be recorded. + +This information can be displayed in various ways---the easiest is to +use the @samp{%d} spec in the group line format: + +@lisp +(setq gnus-group-line-format + "%M\%S\%p\%P\%5y: %(%-40,40g%) %d\n") +@end lisp + +This will result in lines looking like: + +@example +* 0: mail.ding 19961002T012943 + 0: custom 19961002T012713 +@end example + +As you can see, the date is displayed in compact ISO 8601 format. This +may be a bit too much, so to just display the date, you could say +something like: + +@lisp +(setq gnus-group-line-format + "%M\%S\%p\%P\%5y: %(%-40,40g%) %6,6~(cut 2)d\n") +@end lisp + + @node File Commands @subsection File Commands @cindex file commands @@ -2460,7 +2957,7 @@ @findex gnus-group-read-init-file @vindex gnus-init-file @cindex reading init file -Read the init file (@code{gnus-init-file}, which defaults to +Re-read the init file (@code{gnus-init-file}, which defaults to @file{~/.gnus}) (@code{gnus-group-read-init-file}). @item s @@ -2486,6 +2983,11 @@ A line for each article is displayed in the summary buffer. You can move around, read articles, post articles and reply to articles. +The most common way to a summary buffer is to select a group from the +group buffer (@pxref{Selecting a Group}). + +You can have as many summary buffers open as you wish. + @menu * Summary Buffer Format:: Deciding how the summary buffer is to look. * Summary Maneuvering:: Moving around the summary buffer. @@ -2504,6 +3006,7 @@ * Saving Articles:: Ways of customizing article saving. * Decoding Articles:: Gnus can treat series of (uu)encoded articles. * Article Treatment:: The article buffer can be mangled at will. +* Article Commands:: Doing various things with the article buffer. * Summary Sorting:: Sorting the summary buffer in various ways. * Finding the Parent:: No child support? Get the parent. * Alternative Approaches:: Reading using non-default summaries. @@ -2511,6 +3014,8 @@ * Mail Group Commands:: Some commands can only be used in mail groups. * Various Summary Stuff:: What didn't fit anywhere else. * Exiting the Summary Buffer:: Returning to the Group buffer. +* Crosspost Handling:: How crossposted articles are dealt with. +* Duplicate Suppression:: An alternative when crosspost handling fails. @end menu @@ -2548,7 +3053,8 @@ @vindex gnus-summary-line-format You can change the format of the lines in the summary buffer by changing the @code{gnus-summary-line-format} variable. It works along the same -lines a a normal @code{format} string, with some extensions. +lines a a normal @code{format} string, with some extensions +(@pxref{Formatting Variables}). The default string is @samp{%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n}. @@ -2560,16 +3066,18 @@ @item S Subject string. @item s -Subject if the article is the root, @code{gnus-summary-same-subject} -otherwise. +Subject if the article is the root or the previous article had a +different subject, @code{gnus-summary-same-subject} otherwise. +(@code{gnus-summary-same-subject} defaults to @samp{}.) @item F -Full @code{From} line. +Full @code{From} header. @item n The name (from the @code{From} header). @item a The name (from the @code{From} header). This differs from the @code{n} -spec in that it uses @code{gnus-extract-address-components}, which is -slower, but may be more thorough. +spec in that it uses the function designated by the +@code{gnus-extract-address-components} variable, which is slower, but +may be more thorough. @item A The address (from the @code{From} header). This works the same way as the @code{a} spec. @@ -2582,11 +3090,11 @@ @item T Nothing if the article is a root and lots of spaces if it isn't (it pushes everything after it off the screen). -@item \[ -Opening bracket, which is normally @samp{\[}, but can also be @samp{<} -for adopted articles. -@item \] -Closing bracket, which is normally @samp{\]}, but can also be @samp{>} +@item [ +Opening bracket, which is normally @samp{[}, but can also be @samp{<} +for adopted articles (@pxref{Customizing Threading}). +@item ] +Closing bracket, which is normally @samp{]}, but can also be @samp{>} for adopted articles. @item > One space for each thread level. @@ -2610,6 +3118,10 @@ @code{Xref}. @item D @code{Date}. +@item d +The @code{Date} in @code{DD-MMM} format. +@item o +The @code{Date} in @code{YYYYMMDDTHHMMSS} format. @item M @code{Message-ID}. @item r @@ -2618,7 +3130,10 @@ Number of articles in the current sub-thread. Using this spec will slow down summary buffer generation somewhat. @item e -A single character will be displayed if the article has any children. +An @samp{=} (@code{gnus-not-empty-thread-mark}) will be displayed if the +article has any children. +@item P +The line number. @item u User defined specifier. The next character in the format string should be a letter. @sc{gnus} will call the function @@ -2646,8 +3161,10 @@ @vindex gnus-summary-mode-line-format You can also change the format of the summary mode bar. Set -@code{gnus-summary-mode-line-format} to whatever you like. Here are the -elements you can play with: +@code{gnus-summary-mode-line-format} to whatever you like. The default +is @samp{Gnus: %%b [%A] %Z}. + +Here are the elements you can play with: @table @samp @item G @@ -2664,7 +3181,7 @@ Number of unselected articles in this group. @item Z A string with the number of unread and unselected articles represented -either as @samp{<%U(+%u) more>} if there are both unread and unselected +either as @samp{<%U(+%e) more>} if there are both unread and unselected articles, and just as @samp{<%U more>} if there are just unread articles and no unselected ones. @item g @@ -2673,7 +3190,7 @@ @item S Subject of the current article. @item u -Used-defined spec. +User-defined spec. @item s Name of the current score file. @item d @@ -2711,7 +3228,7 @@ @item gnus-summary-highlight @vindex gnus-summary-highlight Summary lines are highlighted according to this variable, which is a -list where the elements are on the format @code{(FORM . FACE)}. If you +list where the elements are on the format @var{(FORM . FACE)}. If you would, for instance, like ticked articles to be italic and high-scored articles to be bold, you could set this variable to something like @lisp @@ -2754,14 +3271,14 @@ @kindex j (Summary) @kindex G j (Summary) @findex gnus-summary-goto-article -Ask for an article number and then go that article +Ask for an article number and then go to that article (@code{gnus-summary-goto-article}). @item G g @kindex G g (Summary) @findex gnus-summary-goto-subject Ask for an article number and then go the summary line of that article -(@code{gnus-summary-goto-subject}). +without displaying the article (@code{gnus-summary-goto-subject}). @end table If Gnus asks you to press a key to confirm going to the next group, you @@ -2775,18 +3292,18 @@ @vindex gnus-auto-select-next @item gnus-auto-select-next -If you are at the end of the group and issue one of the movement -commands, Gnus will offer to go to the next group. If this variable is -@code{t} and the next group is empty, Gnus will exit summary mode and -return to the group buffer. If this variable is neither @code{t} nor -@code{nil}, Gnus will select the next group, no matter whether it has -any unread articles or not. As a special case, if this variable is -@code{quietly}, Gnus will select the next group without asking for -confirmation. If this variable is @code{almost-quietly}, the same will -happen only if you are located on the last article in the group. -Finally, if this variable is @code{slightly-quietly}, the @kbd{Z n} -command will go to the next group without confirmation. Also -@pxref{Group Levels}. +If you issue one of the movement commands (like @kbd{n}) and there are +no more unread articles after the current one, Gnus will offer to go to +the next group. If this variable is @code{t} and the next group is +empty, Gnus will exit summary mode and return to the group buffer. If +this variable is neither @code{t} nor @code{nil}, Gnus will select the +next group, no matter whether it has any unread articles or not. As a +special case, if this variable is @code{quietly}, Gnus will select the +next group without asking for confirmation. If this variable is +@code{almost-quietly}, the same will happen only if you are located on +the last article in the group. Finally, if this variable is +@code{slightly-quietly}, the @kbd{Z n} command will go to the next group +without confirmation. Also @pxref{Group Levels}. @item gnus-auto-select-same @vindex gnus-auto-select-same @@ -2819,6 +3336,15 @@ @section Choosing Articles @cindex selecting articles +@menu +* Choosing Commands:: Commands for choosing articles. +* Choosing Variables:: Variables that influence these commands. +@end menu + + +@node Choosing Commands +@subsection Choosing Commands + None of the following movement commands understand the numeric prefix, and they all select and display an article. @@ -2900,6 +3426,10 @@ history as you like. @end table + +@node Choosing Variables +@subsection Choosing Variables + Some variables that are relevant for moving and selecting articles: @table @code @@ -2983,7 +3513,9 @@ Scroll to the end of the article (@code{gnus-summary-end-of-article}). @item A s +@itemx s @kindex A s (Summary) +@kindex s (Summary) @findex gnus-summary-isearch-article Perform an isearch in the article buffer (@code{gnus-summary-isearch-article}). @@ -3026,17 +3558,25 @@ original message (@code{gnus-summary-reply-with-original}). This command uses the process/prefix convention. +@item S w +@kindex S w (Summary) +@findex gnus-summary-wide-reply +Mail a wide reply to the author of the current article +(@code{gnus-summary-wide-reply}). + +@item S W +@kindex S W (Summary) +@findex gnus-summary-wide-reply-with-original +Mail a wide reply to the current article and include the original +message (@code{gnus-summary-reply-with-original}). This command uses +the process/prefix convention. + @item S o m @kindex S o m (Summary) @findex gnus-summary-mail-forward Forward the current article to some other person -(@code{gnus-summary-mail-forward}). - -@item S o p -@kindex S o p (Summary) -@findex gnus-summary-post-forward -Forward the current article to a newsgroup -(@code{gnus-summary-post-forward}). +(@code{gnus-summary-mail-forward}). If given a prefix, include the full +headers of the forwarded article. @item S m @itemx m @@ -3075,7 +3615,10 @@ ship a mail to a different account of yours. (If you're both @code{root} and @code{postmaster} and get a mail for @code{postmaster} to the @code{root} account, you may want to resend it to -@code{postmaster}. Ordnung muss sein! +@code{postmaster}. Ordnung muß sein! + +This command understands the process/prefix convention +(@pxref{Process/Prefix}). @item S O m @kindex S O m (Summary) @@ -3084,11 +3627,21 @@ (@code{gnus-uu-digest-mail-forward}). This command uses the process/prefix convention (@pxref{Process/Prefix}). -@item S O p -@kindex S O p (Summary) -@findex gnus-uu-digest-post-forward -Digest the current series and forward the result to a newsgroup -(@code{gnus-uu-digest-mail-forward}). +@item S M-c +@kindex S M-c (Summary) +@findex gnus-summary-mail-crosspost-complaint +@cindex crossposting +@cindex excessive crossposting +Send a complaint about excessive crossposting to the author of the +current article (@code{gnus-summary-mail-crosspost-complaint}). + +@findex gnus-crosspost-complaint +This command is provided as a way to fight back agains the current +crossposting pandemic that's sweeping Usenet. It will compose a reply +using the @code{gnus-crosspost-complaint} variable as a preamble. This +command understands the process/prefix convention +(@pxref{Process/Prefix}) and will prompt you before sending each mail. + @end table @@ -3097,7 +3650,7 @@ @cindex post @cindex composing news -Commands for posting an article: +Commands for posting a news article: @table @kbd @item S p @@ -3124,6 +3677,33 @@ (@code{gnus-summary-followup-with-original}). This command uses the process/prefix convention. +@item S n +@kindex S n (Summary) +@findex gnus-summary-followup-to-mail +Post a followup to the current article via news, even if you got the +message through mail (@code{gnus-summary-followup-to-mail}). + +@item S n +@kindex S n (Summary) +@findex gnus-summary-followup-to-mail +Post a followup to the current article via news, even if you got the +message through mail and include the original message +(@code{gnus-summary-followup-to-mail-with-original}). This command uses +the process/prefix convention. + +@item S o p +@kindex S o p (Summary) +@findex gnus-summary-post-forward +Forward the current article to a newsgroup +(@code{gnus-summary-post-forward}). If given a prefix, include the full +headers of the forwarded article. + +@item S O p +@kindex S O p (Summary) +@findex gnus-uu-digest-post-forward +Digest the current series and forward the result to a newsgroup +(@code{gnus-uu-digest-mail-forward}). + @item S u @kindex S u (Summary) @findex gnus-uu-post-news @@ -3171,12 +3751,13 @@ If you have just posted the article, and change your mind right away, there is a trick you can use to cancel/supersede the article without waiting for the article to appear on your site first. You simply return -to the post buffer (which is called @code{*post-buf*}). There you will +to the post buffer (which is called @code{*sent ...*}). There you will find the article you just posted, with all the headers intact. Change the @code{Message-ID} header to a @code{Cancel} or @code{Supersedes} -header by substituting one of those words for @code{Message-ID}. Then -just press @kbd{C-c C-c} to send the article as you would do normally. -The previous article will be canceled/superseded. +header by substituting one of those words for the word +@code{Message-ID}. Then just press @kbd{C-c C-c} to send the article as +you would do normally. The previous article will be +canceled/superseded. Just remember, kids: There is no 'c' in 'supersede'. @@ -3214,30 +3795,33 @@ @node Unread Articles @subsection Unread Articles -The following marks mark articles as unread, in one form or other. - -@vindex gnus-dormant-mark -@vindex gnus-ticked-mark +The following marks mark articles as (kinda) unread, in one form or +other. + @table @samp @item ! +@vindex gnus-ticked-mark +Marked as ticked (@code{gnus-ticked-mark}). + @dfn{Ticked articles} are articles that will remain visible always. If you see an article that you find interesting, or you want to put off reading it, or replying to it, until sometime later, you'd typically tick it. However, articles can be expired, so if you want to keep an -article forever, you'll have to save it. Ticked articles have a -@samp{!} (@code{gnus-ticked-mark}) in the first column. +article forever, you'll have to make it persistent (@pxref{Persistent +Articles}). @item ? @vindex gnus-dormant-mark -A @dfn{dormant} article is marked with a @samp{?} -(@code{gnus-dormant-mark}), and will only appear in the summary buffer -if there are followups to it. +Marked as dormant (@code{gnus-dormant-mark}). + +@dfn{Dormant articles} will only appear in the summary buffer if there +are followups to it. @item SPACE @vindex gnus-unread-mark -An @dfn{unread} article is marked with a @samp{SPACE} -(@code{gnus-unread-mark}). These are articles that haven't been read at -all yet. +Markes as unread (@code{gnus-unread-mark}). + +@dfn{Unread articles} are articles that haven't been read at all yet. @end table @@ -3251,19 +3835,17 @@ @item r @vindex gnus-del-mark -Articles that are marked as read. They have a @samp{r} -(@code{gnus-del-mark}) in the first column. These are articles that the -user has marked as read more or less manually. +These are articles that the user has marked as read with the @kbd{d} +command manually, more or less (@code{gnus-del-mark}). @item R @vindex gnus-read-mark -Articles that are actually read are marked with @samp{R} -(@code{gnus-read-mark}). +Articles that have actually been read (@code{gnus-read-mark}). @item O @vindex gnus-ancient-mark -Articles that were marked as read in previous sessions are now -@dfn{old} and marked with @samp{O} (@code{gnus-ancient-mark}). +Articles that were marked as read in previous sessions and are now +@dfn{old} (@code{gnus-ancient-mark}). @item K @vindex gnus-killed-mark @@ -3287,28 +3869,35 @@ @item F @vindex gnus-souped-mark -@sc{SOUP}ed article (@code{gnus-souped-mark}). +@sc{SOUP}ed article (@code{gnus-souped-mark}). @xref{SOUP}. @item Q @vindex gnus-sparse-mark -Sparsely reffed article (@code{gnus-sparse-mark}). +Sparsely reffed article (@code{gnus-sparse-mark}). @xref{Customizing +Threading}. + +@item M +@vindex gnus-duplicate-mark +Article marked as read by duplicate suppression +(@code{gnus-duplicated-mark}). @xref{Duplicate Suppression}. + @end table All these marks just mean that the article is marked as read, really. -They are interpreted differently by the adaptive scoring scheme, -however. +They are interpreted differently when doing adaptive scoring, though. One more special mark, though: @table @samp @item E @vindex gnus-expirable-mark -You can also mark articles as @dfn{expirable} (or have them marked as -such automatically). That doesn't make much sense in normal groups, -because a user does not control the expiring of news articles, but in -mail groups, for instance, articles that are marked as @dfn{expirable} -can be deleted by Gnus at any time. Expirable articles are marked with -@samp{E} (@code{gnus-expirable-mark}). +Marked as expirable (@code{gnus-expirable-mark}). + +Marking articles as @dfn{expirable} (or have them marked as such +automatically) doesn't make much sense in normal groups---a user doesn't +control the expiring of news articles, but in mail groups, for instance, +articles that are marked as @dfn{expirable} can be deleted by Gnus at +any time. @end table @@ -3327,7 +3916,7 @@ long thesis on cats' urinary tracts, and have to go home for dinner before you've finished reading the thesis. You can then set a bookmark in the article, and Gnus will jump to this bookmark the next time it -encounters the article. +encounters the article. @xref{Setting Marks} @item @vindex gnus-replied-mark @@ -3402,6 +3991,12 @@ Mark the current article as read (@code{gnus-summary-mark-as-read-forward}). +@item D +@kindex D (Summary) +@findex gnus-summary-mark-as-read-backward +Mark the current article as read and move point to the previous line +(@code{gnus-summary-mark-as-read-backward}). + @item M k @itemx k @kindex k (Summary) @@ -3422,8 +4017,7 @@ @item M C @kindex M C (Summary) @findex gnus-summary-catchup -Mark all unread articles in the group as read -(@code{gnus-summary-catchup}). +Mark all unread articles as read (@code{gnus-summary-catchup}). @item M C-c @kindex M C-c (Summary) @@ -3535,6 +4129,12 @@ Remove the process mark from all articles (@code{gnus-summary-unmark-all-processable}). +@item M P i +@kindex M P i (Summary) +@findex gnus-uu-invert-processable +Invert the list of process marked articles +(@code{gnus-uu-invert-processable}). + @item M P R @kindex M P R (Summary) @findex gnus-uu-mark-by-regexp @@ -3584,6 +4184,25 @@ @findex gnus-uu-mark-buffer Mark all articles in the buffer in the order they appear (@code{gnus-uu-mark-buffer}). + +@item M P k +@kindex M P k (Summary) +@findex gnus-summary-kill-process-mark +Push the current process mark set onto the stack and unmark all articles +(@code{gnus-summary-kill-process-mark}). + +@item M P y +@kindex M P y (Summary) +@findex gnus-summary-yank-process-mark +Pop the previous process mark set from the stack and restore it +(@code{gnus-summary-yank-process-mark}). + +@item M P w +@kindex M P w (Summary) +@findex gnus-summary-save-process-mark +Push the current process mark set onto the stack +(@code{gnus-summary-save-process-mark}). + @end table @@ -3627,6 +4246,14 @@ Ask for a mark and then limit to all articles that have not been marked with that mark (@code{gnus-summary-limit-to-marks}). +@item / t +@kindex / t (Summary) +@findex gnus-summary-limit-to-age +Ask for a number and then limit the summary buffer to articles that are +older than (or equal to) that number of days +(@code{gnus-summary-limit-to-marks}). If given a prefix, limit to +articles that are younger than that number of days. + @item / n @kindex / n (Summary) @findex gnus-summary-limit-to-articles @@ -3771,20 +4398,21 @@ (setq gnus-simplify-ignored-prefixes (concat "\\`\\[?\\(" + (mapconcat + 'identity + '("looking" + "wanted" "followup" "summary\\( of\\)?" + "help" "query" "problem" "question" + "answer" "reference" "announce" + "How can I" "How to" "Comparison of" + ;; ... + ) + "\\|") + "\\)\\s *\\(" (mapconcat 'identity - '("looking" - "wanted" "followup" "summary\\( of\\)?" - "help" "query" "problem" "question" - "answer" "reference" "announce" - "How can I" "How to" "Comparison of" - ;; ... - ) + '("for" "for reference" "with" "about") "\\|") - "\\)\\s *\\(" - (mapconcat 'identity - '("for" "for reference" "with" "about") - "\\|") - "\\)?\\]?:?[ \t]*")) + "\\)?\\]?:?[ \t]*")) @end lisp All words that match this regexp will be removed before comparing two @@ -3878,6 +4506,13 @@ If non-@code{nil}, all threads will be hidden when the summary buffer is generated. +@item gnus-thread-expunge-below +@vindex gnus-thread-expunge-below +All threads that have a total score (as defined by +@code{gnus-thread-score-function}) less than this number will be +expunged. This variable is @code{nil} by default, which means that no +threads are expunged. + @item gnus-thread-hide-killed @vindex gnus-thread-hide-killed if you kill a thread and this variable is non-@code{nil}, the subtree @@ -3893,7 +4528,15 @@ @item gnus-thread-indent-level @vindex gnus-thread-indent-level This is a number that says how much each sub-thread should be indented. -The default is @code{4}. +The default is 4. + +@item gnus-parse-headers-hook +@vindex gnus-parse-headers-hook +Hook run before parsing any headers. The default value is +@code{(gnus-decode-rfc1522)}, which means that QPized headers will be +slightly decoded in a hackish way. This is likely to change in the +future when Gnus becomes @sc{MIME}ified. + @end table @@ -3908,7 +4551,7 @@ @kindex T k (Summary) @kindex M-C-k (Summary) @findex gnus-summary-kill-thread -Mark all articles in the current sub-thread as read +Mark all articles in the current (sub-)thread as read (@code{gnus-summary-kill-thread}). If the prefix argument is positive, remove all marks instead. If the prefix argument is negative, tick articles instead. @@ -3918,25 +4561,25 @@ @kindex T l (Summary) @kindex M-C-l (Summary) @findex gnus-summary-lower-thread -Lower the score of the current thread +Lower the score of the current (sub-)thread (@code{gnus-summary-lower-thread}). @item T i @kindex T i (Summary) @findex gnus-summary-raise-thread -Increase the score of the current thread +Increase the score of the current (sub-)thread (@code{gnus-summary-raise-thread}). @item T # @kindex T # (Summary) @findex gnus-uu-mark-thread -Set the process mark on the current thread +Set the process mark on the current (sub-)thread (@code{gnus-uu-mark-thread}). @item T M-# @kindex T M-# (Summary) @findex gnus-uu-unmark-thread -Remove the process mark from the current thread +Remove the process mark from the current (sub-)thread (@code{gnus-uu-unmark-thread}). @item T T @@ -3947,13 +4590,13 @@ @item T s @kindex T s (Summary) @findex gnus-summary-show-thread -Expose the thread hidden under the current article, if any +Expose the (sub-)thread hidden under the current article, if any (@code{gnus-summary-show-thread}). @item T h @kindex T h (Summary) @findex gnus-summary-hide-thread -Hide the current (sub)thread (@code{gnus-summary-hide-thread}). +Hide the current (sub-)thread (@code{gnus-summary-hide-thread}). @item T S @kindex T S (Summary) @@ -4113,12 +4756,14 @@ @node Asynchronous Fetching @section Asynchronous Article Fetching @cindex asynchronous article fetching +@cindex article pre-fetch +@cindex pre-fetch If you read your news from an @sc{nntp} server that's far away, the network latencies may make reading articles a chore. You have to wait for a while after pressing @kbd{n} to go to the next article before the article appears. Why can't Gnus just go ahead and fetch the article -while you are reading the previous one? Why not, indeed. +while you are reading the previous one? Why not, indeed. First, some caveats. There are some pitfalls to using asynchronous article fetching, especially the way Gnus does it. @@ -4147,23 +4792,59 @@ Here's how: Set @code{gnus-asynchronous} to @code{t}. The rest should happen automatically. -@vindex nntp-async-number +@vindex gnus-use-article-prefetch You can control how many articles that are to be pre-fetched by setting -@code{nntp-async-number}. This is five by default, which means that when -you read an article in the group, @code{nntp} will pre-fetch the next -five articles. If this variable is @code{t}, @code{nntp} will pre-fetch -all the articles that it can without bound. If it is @code{nil}, no -pre-fetching will be made. - -@vindex gnus-asynchronous-article-function -You may wish to create some sort of scheme for choosing which articles -that @code{nntp} should consider as candidates for pre-fetching. For -instance, you may wish to pre-fetch all articles with high scores, and -not pre-fetch low-scored articles. You can do that by setting the -@code{gnus-asynchronous-article-function}, which will be called with an -alist where the keys are the article numbers. Your function should -return an alist where the articles you are not interested in have been -removed. You could also do sorting on article score and the like. +@code{gnus-use-article-prefetch}. This is 30 by default, which means +that when you read an article in the group, the backend will pre-fetch +the next 30 articles. If this variable is @code{t}, the backend will +pre-fetch all the articles that it can without bound. If it is +@code{nil}, no pre-fetching will be made. + +@vindex gnus-async-prefetch-article-p +@findex gnus-async-read-p +There are probably some articles that you don't want to pre-fetch---read +articles, for instance. Which articles to pre-fetch is controlled by +the @code{gnus-async-prefetch-article-p} variable. This function should +return non-@code{nil} when the article in question is to be +pre-fetched. The default is @code{gnus-async-read-p}, which returns +@code{nil} on read articles. The function is called with an article +data structure as the only parameter. + +If, for instance, you wish to pre-fetch only unread articles that are +shorter than 100 lines, you could say something like: + +@lisp +(defun my-async-short-unread-p (data) + "Return non-nil for short, unread articles." + (and (gnus-data-unread-p data) + (< (mail-header-lines (gnus-data-header data)) + 100))) + +(setq gnus-async-prefetch-article-p 'my-async-short-unread-p) +@end lisp + +These functions will be called many, many times, so they should +preferrably be short and sweet to avoid slowing down Gnus too much. +It's also probably a good idea to byte-compile things like this. + +@vindex gnus-prefetched-article-deletion-strategy +Articles have to be removed from the asynch buffer sooner or later. The +@code{gnus-prefetched-article-deletion-strategy} says when to remove +articles. This is a list that may contain the following elements: + +@table @code +@item read +Remove articles when they are read. + +@item exit +Remove articles when exiting the group. +@end table + +The default value is @code{(read exit)}. + +@vindex gnus-use-header-prefetch +If @code{gnus-use-header-prefetch} is non-@code{nil}, prefetch articles +from the next group. @node Article Caching @@ -4353,6 +5034,12 @@ Save the current article in plain file format (@code{gnus-summary-save-article-file}). +@item O F +@kindex O F (Summary) +@findex gnus-summary-write-article-file +Write the current article in plain file format, overwriting any previous +file contents (@code{gnus-summary-write-article-file}). + @item O b @kindex O b (Summary) @findex gnus-summary-save-article-body-file @@ -4463,19 +5150,19 @@ @item gnus-Numeric-save-name @findex gnus-Numeric-save-name -Generates file names that look like @file{~/News/Alt.andrea-dworkin/45}. +File names like @file{~/News/Alt.andrea-dworkin/45}. @item gnus-numeric-save-name @findex gnus-numeric-save-name -Generates file names that look like @file{~/News/alt.andrea-dworkin/45}. +File names like @file{~/News/alt.andrea-dworkin/45}. @item gnus-Plain-save-name @findex gnus-Plain-save-name -Generates file names that look like @file{~/News/Alt.andrea-dworkin}. +File names like @file{~/News/Alt.andrea-dworkin}. @item gnus-plain-save-name @findex gnus-plain-save-name -Generates file names that look like @file{~/News/alt.andrea-dworkin}. +File names like @file{~/News/alt.andrea-dworkin}. @end table @vindex gnus-split-methods @@ -4724,8 +5411,8 @@ for instance, @code{sox} to convert an @samp{.au} sound file, you could say something like: @lisp - (setq gnus-uu-user-view-rules - (list '(\"\\\\.au$\" \"sox %s -t .aiff > /dev/audio\"))) +(setq gnus-uu-user-view-rules + (list '(\"\\\\.au$\" \"sox %s -t .aiff > /dev/audio\"))) @end lisp @item gnus-uu-user-view-rules-end @@ -4763,6 +5450,13 @@ Move the file (if you're using a saving function.) @end table +@item gnus-uu-be-dangerous +@vindex gnus-uu-be-dangerous +Specifies what to do if unusual situations arise during decoding. If +@code{nil}, be as conservative as possible. If @code{t}, ignore things +that didn't work, and overwrite existing files. Otherwise, ask each +time. + @item gnus-uu-ignore-files-by-name @vindex gnus-uu-ignore-files-by-name Files with name matching this regular expression won't be viewed. @@ -4923,10 +5617,12 @@ @menu * Article Highlighting:: You want to make the article look like fruit salad. +* Article Fontisizing:: Making emphasized text look niced. * Article Hiding:: You also want to make certain info go away. * Article Washing:: Lots of way-neat functions to make life better. * Article Buttons:: Click on URLs, Message-IDs, addresses and the like. * Article Date:: Grumble, UT! +* Article Signature:: What is a signature? @end menu @@ -5021,11 +5717,64 @@ @vindex gnus-signature-face @findex gnus-article-highlight-signature Highlight the signature (@code{gnus-article-highlight-signature}). -Everything after @code{gnus-signature-separator} in an article will be -considered a signature and will be highlighted with -@code{gnus-signature-face}, which is @code{italic} by default. - -@end table +Everything after @code{gnus-signature-separator} (@pxref{Article +Signature}) in an article will be considered a signature and will be +highlighted with @code{gnus-signature-face}, which is @code{italic} by +default. + +@end table + + +@node Article Fontisizing +@subsection Article Fontisizing +@cindex emphasis +@cindex article emphasis + +@findex gnus-article-emphasize +@kindex W e (Summary) +People commonly add emphasis to words in news articles by writing things +like @samp{_this_} or @samp{*this*}. Gnus can make this look nicer by +running the article through the @kbd{W e} +(@code{gnus-article-emphasize}) command. + +@vindex gnus-article-emphasis +How the emphasis is computed is controlled by the +@code{gnus-article-emphasis} variable. This is an alist where 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 text between these two +groupings will be hidden.) The fourth is the face used for +highlighting. + +@lisp +(setq gnus-article-emphasis + '(("_\\(\\w+\\)_" 0 1 gnus-emphasis-underline) + ("\\*\\(\\w+\\)\\*" 0 1 gnus-emphasis-bold))) +@end lisp + +@vindex gnus-emphasis-underline +@vindex gnus-emphasis-bold +@vindex gnus-emphasis-italic +@vindex gnus-emphasis-underline-bold +@vindex gnus-emphasis-underline-italic +@vindex gnus-emphasis-bold-italic +@vindex gnus-emphasis-underline-bold-italic +By default, there are seven rules, and they use the following faces: +@code{gnus-emphasis-bold}, @code{gnus-emphasis-italic}, +@code{gnus-emphasis-underline}, @code{gnus-emphasis-bold-italic}, +@code{gnus-emphasis-underline-italic}, +@code{gnus-emphasis-undeline-bold}, and +@code{gnus-emphasis-underline-bold-italic}. + +If you want to change these faces, you can either use @kbd{M-x +customize}, or you can use @code{copy-face}. For instance, if you want +to make @code{gnus-emphasis-italic} use a red face instead, you could +say something like: + +@lisp +(copy-face 'red 'gnus-emphasis-italic) +@end lisp @node Article Hiding @@ -5057,7 +5806,8 @@ @item W W s @kindex W W s (Summary) @findex gnus-article-hide-signature -Hide signature (@code{gnus-article-hide-signature}). +Hide signature (@code{gnus-article-hide-signature}). @xref{Article +Signature}. @item W W p @kindex W W p (Summary) @@ -5067,7 +5817,7 @@ @item W W P @kindex W W P (Summary) @findex gnus-article-hide-pem -Hide @sc{pem} (privacy enhavnced hessages) gruft +Hide @sc{pem} (privacy enhanced messages) gruft (@code{gnus-article-hide-pem}). @item W W c @@ -5092,7 +5842,8 @@ @vindex gnus-cited-text-button-line-format Gnus adds buttons show where the cited text has been hidden, and to allow toggle hiding the text. The format of the variable is specified -by this format-like variable. These specs are legal: +by this format-like variable (@pxref{Formatting Variables}). These +specs are legal: @table @samp @item b @@ -5126,14 +5877,6 @@ Also @pxref{Article Highlighting} for further variables for citation customization. -@vindex gnus-signature-limit -@code{gnus-signature-limit} provides 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 @code{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. - @node Article Washing @subsection Article Washing @@ -5191,17 +5934,14 @@ function in @code{gnus-article-display-hook}, it should be run fairly late and certainly after any highlighting. +You can give the command a numerical prefix to specify the width to use +when filling. + @item W c @kindex W c (Summary) @findex gnus-article-remove-cr Remove CR (@code{gnus-article-remove-cr}). -@item W L -@kindex W L (Summary) -@findex gnus-article-remove-trailing-blank-lines -Remove all blank lines at the end of the article -(@code{gnus-article-remove-trailing-blank-lines}). - @item W q @kindex W q (Summary) @findex gnus-article-de-quoted-unreadable @@ -5241,6 +5981,31 @@ Add clickable buttons to the article headers (@code{gnus-article-add-buttons-to-head}). +@item W E l +@kindex W E l (Summary) +@findex gnus-article-strip-leading-blank-lines +Remove all blank lines from the beginning of the article +(@code{gnus-article-strip-leading-blank-lines}). + +@item W E m +@kindex W E m (Summary) +@findex gnus-article-strip-multiple-blank-lines +Replace all blank lines with empty lines and then all multiple empty +lines with a single empty line. +(@code{gnus-article-strip-multiple-blank-lines}). + +@item W E t +@kindex W E t (Summary) +@findex gnus-article-remove-trailing-blank-lines +Remove all blank lines at the end of the article +(@code{gnus-article-remove-trailing-blank-lines}). + +@item W E a +@kindex W E a (Summary) +@findex gnus-article-strip-blank-lines +Do all the three commands above +(@code{gnus-article-strip-blank-lines}). + @end table @@ -5277,7 +6042,7 @@ @item button-par Gnus has to know which parts of the match is to be highlighted. This is a number that says what sub-expression of the regexp that is to be -highlighted. If you want it all highlighted, you use @code{0} here. +highlighted. If you want it all highlighted, you use 0 here. @item use-p This form will be @code{eval}ed, and if the result is non-@code{nil}, @@ -5318,7 +6083,7 @@ @item gnus-article-button-face @vindex gnus-article-button-face -Face used on bottons. +Face used on buttons. @item gnus-article-mouse-face @vindex gnus-article-mouse-face @@ -5347,6 +6112,17 @@ @findex gnus-article-date-local Display the date in the local timezone (@code{gnus-article-date-local}). +@item W T s +@kindex W T s (Summary) +@vindex gnus-article-time-format +@findex gnus-article-date-user +@findex format-time-string +Display the date using a user-defined format +(@code{gnus-article-date-user}). The format is specified by the +@code{gnus-article-time-format} variable, and is a string that's passed +to @code{format-time-string}. See the documentation of that variable +for a list possible format specs. + @item W T e @kindex W T e (Summary) @findex gnus-article-date-lapsed @@ -5365,6 +6141,76 @@ @end table +@node Article Signature +@subsection Article Signature +@cindex signatures +@cindex article signature + +@vindex gnus-signature-separator +Each article is divided into two parts---the head and the body. The +body can be divided into a signature part and a text part. The variable +that says what is to be considered a signature is +@code{gnus-signature-separator}. This is normally the standard +@samp{^-- $} as mandated by son-of-RFC 1036. However, many people use +non-standard signature separators, so this variable can also be a list +of regular expressions to be tested, one by one. (Searches are done +from the end of the body towards the beginning.) One likely value is: + +@lisp +(setq gnus-signature-separator + '("^-- $" ; The standard + "^-- *$" ; A common mangling + "^-------*$" ; Many people just use a looong + ; line of dashes. Shame! + "^ *--------*$" ; Double-shame! + "^________*$" ; Underscores are also popular + "^========*$")) ; Pervert! +@end lisp + +The more permissive you are, the more likely it is that you'll get false +positives. + +@vindex gnus-signature-limit +@code{gnus-signature-limit} provides a limit to what is considered a +signature. + +@enumerate +@item +If it is an integer, no signature may be longer (in characters) than +that integer. +@item +If it is a floating point number, no signature may be longer (in lines) +than that number. +@item +If it is a function, the function will be called without any parameters, +and if it returns @code{nil}, there is no signature in the buffer. +@item +If it is a string, it will be used as a regexp. If it matches, the text +in question is not a signature. +@end enumerate + +This variable can also be a list where the elements may be of the types +listed above. + + +@node Article Commands +@section Article Commands + +@table @kbd + +@item A P +@cindex PostScript +@cindex printing +@kindex A P (Summary) +@vindex gnus-ps-print-hook +@findex gnus-summary-print-article +Generate and print a PostScript image of the article buffer +(@code{gnus-summary-print-article}). @code{gnus-ps-print-hook} will be +run just before printing the buffer. + +@end table + + @node Summary Sorting @section Summary Sorting @cindex summary sorting @@ -5394,6 +6240,11 @@ @findex gnus-summary-sort-by-date Sort by date (@code{gnus-summary-sort-by-date}). +@item C-c C-s C-l +@kindex C-c C-s C-l (Summary) +@findex gnus-summary-sort-by-lines +Sort by lines (@code{gnus-summary-sort-by-lines}). + @item C-c C-s C-i @kindex C-c C-s C-i (Summary) @findex gnus-summary-sort-by-score @@ -5424,6 +6275,13 @@ you'll get the parent. If the parent is already displayed in the summary buffer, point will just move to this article. +If given a positive numerical prefix, fetch that many articles back into +the ancestry. If given a negative numerical prefix, fetch just that +ancestor. So if you say @kbd{3 ^}, Gnus will fetch the parent, the +grandparent and the grandgrandparent of the current article. If you say +@kbd{-3 ^}, Gnus will only fetch the grandgrandparent of the current +article. + @findex gnus-summary-refer-references @kindex A R (Summary) You can have Gnus fetch all articles mentioned in the @code{References} @@ -5432,12 +6290,14 @@ @findex gnus-summary-refer-article @kindex M-^ (Summary) +@cindex Message-ID +@cindex fetching by Message-ID You can also ask the @sc{nntp} server for an arbitrary article, no matter what group it belongs to. @kbd{M-^} (@code{gnus-summary-refer-article}) will ask you for a -@code{Message-ID}, which is one of those long thingies that look -something like @samp{<38o6up$6f2@@hymir.ifi.uio.no>}. You have to get -it all exactly right. No fuzzy searches, I'm afraid. +@code{Message-ID}, which is one of those long, hard-to-read thingies +that look something like @samp{<38o6up$6f2@@hymir.ifi.uio.no>}. You +have to get it all exactly right. No fuzzy searches, I'm afraid. @vindex gnus-refer-article-method If the group you are reading is located on a backend that does not @@ -5487,10 +6347,19 @@ Here are the available keystrokes when using pick mode: @table @kbd +@item . +@kindex . (Pick) +@findex gnus-summary-mark-as-processable +Pick the article on the current line +(@code{gnus-summary-mark-as-processable}). If given a numerical prefix, +go to the article on that line and pick that article. (The line number +is normally displayed on the beginning of the summary pick lines.) + @item SPACE @kindex SPACE (Pick) -@findex gnus-summary-mark-as-processable -Pick the article (@code{gnus-summary-mark-as-processable}). +@findex gnus-pick-next-page +Scroll the summary buffer up one page (@code{gnus-pick-next-page}). If +at the end of the buffer, start reading the picked articles. @item u @kindex u (Pick) @@ -5562,6 +6431,18 @@ @vindex gnus-pick-mode-hook @code{gnus-pick-mode-hook} is run in pick minor mode buffers. +@vindex gnus-mark-unpicked-articles-as-read +If @code{gnus-mark-unpicked-articles-as-read} is non-@code{nil}, mark +all unpicked articles as read. The default is @code{nil}. + +@vindex gnus-summary-pick-line-format +The summary line format in pick mode is slightly different than the +standard format. At the beginning of each line the line number is +displayed. The pick mode line format is controlled by the +@code{gnus-summary-pick-line-format} variable (@pxref{Formatting +Variables}). It accepts the same format specs that +@code{gnus-summary-line-format} does (@pxref{Summary Buffer Lines}). + @node Binary Groups @subsection Binary Groups @@ -5677,10 +6558,10 @@ @example @{***@}-(***)-[odd]-[Gun] - | \[Jan] - | \[odd]-[Eri] - | \(***)-[Eri] - | \[odd]-[Paa] + | \[Jan] + | \[odd]-[Eri] + | \(***)-[Eri] + | \[odd]-[Paa] \[Bjo] \[Gun] \[Gun]-[Jor] @@ -5722,7 +6603,7 @@ @item B M-C-e @kindex B M-C-e (Summary) @findex gnus-summary-expire-articles-now -Expunge all the expirable articles in the group +Delete all the expirable articles in the group (@code{gnus-summary-expire-articles-now}). This means that @strong{all} articles that are eligible for expiry in the current group will disappear forever into that big @file{/dev/null} in the sky. @@ -5768,6 +6649,9 @@ @kindex B r (Summary) @findex gnus-summary-respool-article Respool the mail article (@code{gnus-summary-move-article}). +@code{gnus-summary-respool-default-method} will be used as the default +select method when respooling. This variable is @code{nil} by default, +which means that the current group select method will be used instead. @item B w @itemx e @@ -5785,6 +6669,21 @@ If you want to re-spool an article, you might be curious as to what group the article will end up in before you do the re-spooling. This command will tell you (@code{gnus-summary-respool-query}). + +@item B p +@kindex B p (Summary) +@findex gnus-summary-article-posted-p +Some people have a tendency to send you "courtesy" copies when they +follow up to articles you have posted. These usually have a +@code{Newsgroups} header in them, but not always. This command +(@code{gnus-summary-article-posted-p}) will try to fetch the current +article from your news server (or rather, from +@code{gnus-refer-article-method} or @code{gnus-select-method}) and will +report back whether it found the article or not. Even if it says that +it didn't find the article, it may have been posted anyway---mail +propagation is much faster than news propagation, and the news copy may +just not have arrived yet. + @end table @vindex gnus-move-split-methods @@ -5795,6 +6694,13 @@ (@pxref{Saving Articles}). You may customize that variable to create suggestions you find reasonable. +@lisp +(setq gnus-move-split-methods + '(("^From:.*Lars Magne" "nnml:junk") + ("^Subject:.*gnus" "nnfolder:important") + (".*" "nnml:misc"))) +@end lisp + @node Various Summary Stuff @section Various Summary Stuff @@ -5802,6 +6708,7 @@ @menu * Summary Group Information:: Information oriented commands. * Searching for Articles:: Multiple article commands. +* Summary Generation Commands:: (Re)generating the summary buffer. * Really Various Summary Commands:: Those pesky non-conformant commands. @end menu @@ -5854,8 +6761,8 @@ @item H h @kindex H h (Summary) @findex gnus-summary-describe-briefly -Give a very brief description of the most important summary keystrokes -(@code{gnus-summary-describe-briefly}). +Give an extremely brief description of the most important summary +keystrokes (@code{gnus-summary-describe-briefly}). @item H i @kindex H i (Summary) @@ -5895,14 +6802,32 @@ the process mark (@code{gnus-summary-universal-argument}). @end table +@node Summary Generation Commands +@subsection Summary Generation Commands + +@table @kbd + +@item Y g +@kindex Y g (Summary) +@findex gnus-summary-prepare +Regenerate the current summary buffer (@code{gnus-summary-prepare}). + +@item Y c +@kindex Y c (Summary) +@findex gnus-summary-insert-cached-articles +Pull all cached articles (for the current group) into the summary buffer +(@code{gnus-summary-insert-cached-articles}). + +@end table + @node Really Various Summary Commands @subsection Really Various Summary Commands @table @kbd -@item A D -@kindex A D (Summary) +@item C-d +@kindex C-d (Summary) @findex gnus-summary-enter-digest-group If the current article is a collection of other articles (for instance, a digest), you might use this command to enter a group based on the that @@ -5910,19 +6835,34 @@ guess what article type is currently displayed unless you give a prefix to this command, which forces a ``digest'' interpretation. Basically, whenever you see a message that is a collection of other messages on -some format, you @kbd{A D} and read these messages in a more convenient +some format, you @kbd{C-d} and read these messages in a more convenient fashion. +@item M-C-d +@kindex M-C-d (Summary) +@findex gnus-summary-read-document +This command is very similar to the one above, but lets you gather +several documents into one biiig group +(@code{gnus-summary-read-document}). It does this by opening several +@code{nndoc} groups for each document, and then opening an +@code{nnvirtual} group on top of these @code{nndoc} groups. This +command understands the process/prefix convention +(@pxref{Process/Prefix}). + @item C-t @kindex C-t (Summary) @findex gnus-summary-toggle-truncation -Toggle truncation of summary lines (@code{gnus-summary-toggle-truncation}). +Toggle truncation of summary lines +(@code{gnus-summary-toggle-truncation}). This will probably confuse the +line centering function in the summary buffer, so it's not a good idea +to have truncation switched off while reading articles. @item = @kindex = (Summary) @findex gnus-summary-expand-window Expand the summary buffer window (@code{gnus-summary-expand-window}). If given a prefix, force an @code{article} window configuration. + @end table @@ -5948,7 +6888,8 @@ called before doing much of the exiting, and calls @code{gnus-summary-expire-articles} by default. @code{gnus-summary-exit-hook} is called after finishing the exiting -process. +process. @code{gnus-group-no-more-groups-hook} is run when returning to +group mode having no more (unread) groups. @item Z E @itemx Q @@ -6005,6 +6946,14 @@ @findex gnus-summary-prev-group Exit the group and go to the previous group (@code{gnus-summary-prev-group}). + +@item Z s +@kindex Z s (Summary) +@findex gnus-summary-save-newsrc +Save the current number of read/marked articles in the dribble buffer +and then save the dribble buffer (@code{gnus-summary-save-newsrc}). If +given a prefix, also save the @file{.newsrc} file(s). Using this +command will make exit without updating (the @kbd{Q} command) worthless. @end table @vindex gnus-exit-group-hook @@ -6034,7 +6983,11 @@ this group and are marked as read, will also be marked as read in the other subscribed groups they were cross-posted to. If this variable is neither @code{nil} nor @code{t}, the article will be marked as read in -both subscribed and unsubscribed groups. +both subscribed and unsubscribed groups (@pxref{Crosspost Handling}). + + +@node Crosspost Handling +@section Crosspost Handling @cindex velveeta @cindex spamming @@ -6043,11 +6996,14 @@ posted it to several groups separately. Posting the same article to several groups (not cross-posting) is called @dfn{spamming}, and you are by law required to send nasty-grams to anyone who perpetrates such a -heinous crime. +heinous crime. You may want to try NoCeM handling to filter out spam +(@pxref{NoCeM}). Remember: Cross-posting is kinda ok, but posting the same article separately to several groups is not. Massive cross-posting (aka. -@dfn{velveeta}) is to be avoided. +@dfn{velveeta}) is to be avoided at all costs, and you can even use the +@code{gnus-summary-mail-crosspost-complaint} command to complain about +excessive crossposting (@pxref{Summary Mail Commands}). @cindex cross-posting @cindex Xref @@ -6080,6 +7036,85 @@ C'est la vie. +For an alternative approach, @pxref{Duplicate Suppression}. + + +@node Duplicate Suppression +@section Duplicate Suppression + +By default, Gnus tries to make sure that you don't have to read the same +article more than once by utilizing the crossposting mechanism +(@pxref{Crosspost Handling}). However, that simple and efficient +approach may not work satisfactorily for some users for various +reasons. + +@enumerate +@item +The @sc{nntp} server may fail to generate the @code{Xref} header. This +is evil and not very common. + +@item +The @sc{nntp} server may fail to include the @code{Xref} header in the +@file{.overview} data bases. This is evil and all too common, alas. + +@item +You may be reading the same group (or several related groups) from +different @sc{nntp} servers. + +@item +You may be getting mail that duplicates articles posted to groups. +@end enumerate + +I'm sure there are other situations that @code{Xref} handling fails as +well, but these four are the most common situations. + +If, and only if, @code{Xref} handling fails for you, then you may +consider switching on @dfn{duplicate suppression}. If you do so, Gnus +will remember the @code{Message-ID}s of all articles you have read or +otherwise marked as read, and then, as if by magic, mark them as read +all subsequent times you see them---in @emph{all} groups. Using this +mechanism is quite likely to be somewhat inefficient, but not overly +so. It's certainly preferable to reading the same articles more than +once. + +Duplicate suppression is not a very subtle instrument. It's more like a +sledge hammer than anything else. It works in a very simple +fashion---if you have marked an article as read, it adds this Message-ID +to a cache. The next time it sees this Message-ID, it will mark the +article as read the the @samp{M} mark. It doesn't care what group it +saw the article in. + +@table @code +@item gnus-suppress-duplicates +@vindex gnus-suppress-duplicates +If non-@code{nil}, suppress duplicates. + +@item gnus-save-duplicate-list +@vindex gnus-save-duplicate-list +If non-@code{nil}, save the list of duplicates to a file. This will +make startup and shutdown take longer, so the default is @code{nil}. +However, this means that only duplicate articles that is read in a +single Gnus session are suppressed. + +@item gnus-duplicate-list-length +@vindex gnus-duplicate-list-length +This variables says how many @code{Message-ID}s to keep in the duplicate +suppression list. The default is 10000. + +@item gnus-duplicate-file +@vindex gnus-duplicate-file +The name of the file to store the duplicate suppression list. The +default is @file{~/News/suppression}. +@end table + +If you have a tendency to stop and start Gnus often, setting +@code{gnus-save-duplicate-list} to @code{t} is probably a good idea. If +you leave Gnus running for weeks on end, you may have it @code{nil}. On +the other hand, saving the list makes startup and shutdown much slower, +so that means that if you stop and start Gnus often, you should set +@code{gnus-save-duplicate-list} to @code{nil}. Uhm. I'll leave this up +to you to figure out, I think. + @node The Article Buffer @chapter The Article Buffer @@ -6093,7 +7128,7 @@ * Hiding Headers:: Deciding what headers should be displayed. * Using MIME:: Pushing articles through @sc{mime} before reading them. * Customizing Articles:: Tailoring the look of the articles. -* Article Keymap:: Keystrokes available in the article buffer +* Article Keymap:: Keystrokes available in the article buffer. * Misc Article:: Other stuff. @end menu @@ -6231,12 +7266,14 @@ @vindex gnus-show-mime-method @vindex gnus-strict-mime @findex metamail-buffer -Gnus handles @sc{mime} by shoving the articles through +Gnus handles @sc{mime} by pushing the articles through @code{gnus-show-mime-method}, which is @code{metamail-buffer} by default. Set @code{gnus-show-mime} to @code{t} if you want to use @sc{mime} all the time. However, if @code{gnus-strict-mime} is non-@code{nil}, the @sc{mime} method will only be used if there are -@sc{mime} headers in the article. +@sc{mime} headers in the article. If you have @code{gnus-show-mime} +set, then you'll see some unfortunate display glitches in the article +buffer. These can't be avoided. It might be best to just use the toggling functions from the summary buffer to avoid getting nasty surprises. (For instance, you enter the @@ -6261,13 +7298,14 @@ treatment of the article before it is displayed. @findex gnus-article-maybe-highlight -By default it contains @code{gnus-article-hide-headers}, +By default this hook just contains @code{gnus-article-hide-headers}, @code{gnus-article-treat-overstrike}, and @code{gnus-article-maybe-highlight}, but there are thousands, nay millions, of functions you can put in this hook. For an overview of functions @pxref{Article Highlighting}, @pxref{Article Hiding}, @pxref{Article Washing}, @pxref{Article Buttons} and @pxref{Article -Date}. +Date}. Note that the order of functions in this hook might affect +things, so you may have to fiddle a bit to get the desired results. You can, of course, write your own functions. The functions are called from the article buffer, and you can do anything you like, pretty much. @@ -6366,11 +7404,24 @@ @vindex gnus-article-mode-hook Hook called in article mode buffers. +@item gnus-article-mode-syntax-table +@vindex gnus-article-mode-syntax-table +Syntax table used in article buffers. It is initialized from +@code{text-mode-syntax-table}. + @vindex gnus-article-mode-line-format @item gnus-article-mode-line-format This variable is a format string along the same lines as -@code{gnus-summary-mode-line-format}. It accepts exactly the same -format specifications as that variable. +@code{gnus-summary-mode-line-format}. It accepts the same +format specifications as that variable, with one extension: + +@table @samp +@item w +The @dfn{wash status} of the article. This is a short string with one +character for each possible article wash operation that may have been +performed. +@end table + @vindex gnus-break-pages @item gnus-break-pages @@ -6479,7 +7530,7 @@ can use a non-zero prefix to the @kbd{C-c C-c} command to force using the ``current'' server for posting. -If you give a zero prefix (i. e., @kbd{C-u 0 C-c C-c}) to that command, +If you give a zero prefix (i.e., @kbd{C-u 0 C-c C-c}) to that command, Gnus will prompt you for what method to use for posting. You can also set @code{gnus-post-method} to a list of select methods. @@ -6528,17 +7579,23 @@ Gnus provides a few different methods for storing the mail you send. The default method is to use the @dfn{archive virtual server} to store -the mail. If you want to disable this completely, you should set -@code{gnus-message-archive-group} to @code{nil}. +the mail. If you want to disable this completely, the +@code{gnus-message-archive-group} variable should be @code{nil}, which +is the default. @vindex gnus-message-archive-method @code{gnus-message-archive-method} says what virtual server Gnus is to -use to store sent messages. It is @code{(nnfolder "archive" -(nnfolder-directory "~/Mail/archive/"))} by default, but you can use any -mail select method (@code{nnml}, @code{nnmbox}, etc.). However, -@code{nnfolder} is a quite likeable select method for doing this sort of -thing. If you don't like the default directory chosen, you could say -something like: +use to store sent messages. The default is: + +@lisp +(nnfolder "archive" + (nnfolder-directory "~/Mail/archive/")) +@end lisp + +You can, however, use any mail select method (@code{nnml}, +@code{nnmbox}, etc.). @code{nnfolder} is a quite likeable select method +for doing this sort of thing, though. If you don't like the default +directory chosen, you could say something like: @lisp (setq gnus-message-archive-method @@ -6617,15 +7674,14 @@ nice---@samp{misc-mail-september-1995}, or whatever. New messages will continue to be stored in the old (now empty) group. -That's the default method of archiving sent mail. Gnus also offers two -other variables for the people who don't like the default method. In -that case you should set @code{gnus-message-archive-group} to -@code{nil}; this will disable archiving. +That's the default method of archiving sent mail. Gnus also a different +way for the people who don't like the default method. In that case you +should set @code{gnus-message-archive-group} to @code{nil}; this will +disable archiving. XEmacs 19.13 doesn't have @code{format-time-string}, so you'll have to use a different value for @code{gnus-message-archive-group} there. - @table @code @item gnus-outgoing-message-group @vindex gnus-outgoing-message-group @@ -6816,7 +7872,7 @@ A foreign group (or any group, really) is specified by a @dfn{name} and a @dfn{select method}. To take the latter first, a select method is a -list where the first element says what backend to use (eg. @code{nntp}, +list where the first element says what backend to use (e.g. @code{nntp}, @code{nnspool}, @code{nnml}) and the second element is the @dfn{server name}. There may be additional elements in the select method, where the value may have special meaning for the backend in question. @@ -6829,9 +7885,9 @@ For instance, the group @samp{soc.motss} on the @sc{nntp} server @samp{some.where.edu} will have the name @samp{soc.motss} and select -method @code{(nntp "some.where.edu")}. Gnus will call this group, in -all circumstances, @samp{nntp+some.where.edu:soc.motss}, even though the -@code{nntp} backend just knows this group as @samp{soc.motss}. +method @code{(nntp "some.where.edu")}. Gnus will call this group +@samp{nntp+some.where.edu:soc.motss}, even though the @code{nntp} +backend just knows this group as @samp{soc.motss}. The different methods all have their peculiarities, of course. @@ -6861,7 +7917,7 @@ These select methods specifications can sometimes become quite complicated---say, for instance, that you want to read from the -@sc{nntp} server @samp{news.funet.fi} on port number @code{13}, which +@sc{nntp} server @samp{news.funet.fi} on port number 13, which hangs if queried for @sc{nov} headers and has a buggy select. Ahem. Anyways, if you had to specify that for each group that used this server, that would be too much work, so Gnus offers a way of naming @@ -6969,6 +8025,20 @@ @findex gnus-server-list-servers List all servers (@code{gnus-server-list-servers}). +@item s +@kindex s (Server) +@findex gnus-server-scan-server +Request that the server scan its sources for new articles +(@code{gnus-server-scan-server}). This is mainly sensible with mail +servers. + +@item g +@kindex g (Server) +@findex gnus-server-regenerate-server +Request that the server regenerate all its data structures +(@code{gnus-server-regenerate-server}). This can be useful if you have +a mail backend that has gotten out of synch. + @end table @@ -6995,7 +8065,7 @@ @var{(variable form)} pairs. To go back to the first example---imagine that you want to read from -port @code{15} from that machine. This is what the select method should +port 15 from that machine. This is what the select method should look like then: @lisp @@ -7025,6 +8095,22 @@ (nnmh-get-new-mail nil)) @end lisp +If you are behind a firewall and only have access to the @sc{nntp} +server from the firewall machine, you can instruct Gnus to @code{rlogin} +on the firewall machine and telnet from there to the @sc{nntp} server. +Doing this can be rather fiddly, but your virtual server definition +should probably look something like this: + +@lisp +(nntp "firewall" + (nntp-address "the.firewall.machine") + (nntp-open-connection-function nntp-open-rlogin) + (nntp-end-of-line "\n") + (nntp-rlogin-parameters + ("telnet" "the.real.nntp.host" "nntp"))) +@end lisp + + @node Creating a Virtual Server @subsection Creating a Virtual Server @@ -7051,9 +8137,9 @@ @lisp (nnspool "cache" - (nnspool-spool-directory "~/News/cache/") - (nnspool-nov-directory "~/News/cache/") - (nnspool-active-file "~/News/cache/active")) + (nnspool-spool-directory "~/News/cache/") + (nnspool-nov-directory "~/News/cache/") + (nnspool-active-file "~/News/cache/active")) @end lisp Type @kbd{C-c C-c} to return to the server buffer. If you now press @@ -7065,7 +8151,7 @@ @subsection Servers and Methods Wherever you would normally use a select method -(eg. @code{gnus-secondary-select-method}, in the group select method, +(e.g. @code{gnus-secondary-select-method}, in the group select method, when browsing a foreign server) you can use a virtual server name instead. This could potentially save lots of typing. And it's nice all over. @@ -7115,6 +8201,18 @@ Mark the current server as unreachable (@code{gnus-server-deny-server}). +@item M-o +@kindex M-o (Server) +@findex gnus-server-open-all-servers +Open the connections to all servers in the buffer +(@code{gnus-server-open-all-servers}). + +@item M-c +@kindex M-c (Server) +@findex gnus-server-close-all-servers +Close the connections to all servers in the buffer +(@code{gnus-server-close-all-servers}). + @item R @kindex R (Server) @findex gnus-server-remove-denials @@ -7172,9 +8270,28 @@ @code{nntp-server-opened-hook} is run after a connection has been made. It can be used to send commands to the @sc{nntp} server after it has been contacted. By default is sends the command @code{MODE READER} to -the server with the @code{nntp-send-mode-reader} function. Another -popular function is @code{nntp-send-authinfo}, which will prompt you for -an @sc{nntp} password and stuff. +the server with the @code{nntp-send-mode-reader} function. + +@item nntp-authinfo-function +@vindex nntp-authinfo-function +This function will be used to send @samp{AUTHINFO} to the @sc{nntp} +server. Available functions include: + +@table @code +@item nntp-send-authinfo +@findex nntp-send-authinfo +This function will used you current login name as the user name and will +prompt you for the password. This is the default. + +@item nntp-send-nosy-authinfo +@findex nntp-send-nosy-authinfo +This function will prompt you for both user name and password. + +@item nntp-send-authinfo-from-file +@findex nntp-send-authinfo-from-file +This function will use your current login name as the user name and will +read the @sc{nntp} password from @file{~/.nntp-authinfo}. +@end table @item nntp-server-action-alist @vindex nntp-server-action-alist @@ -7246,8 +8363,8 @@ @findex nntp-open-rlogin @findex nntp-open-network-stream -@item nntp-open-server-function -@vindex nntp-open-server-function +@item nntp-open-connection-function +@vindex nntp-open-connection-function This function is used to connect to the remote system. Two pre-made functions are @code{nntp-open-network-stream}, which is the default, and simply connects to some port or other on the remote system. The other @@ -7257,7 +8374,7 @@ @item nntp-rlogin-parameters @vindex nntp-rlogin-parameters If you use @code{nntp-open-rlogin} as the -@code{nntp-open-server-function}, this list will be used as the +@code{nntp-open-connection-function}, this list will be used as the parameter list given to @code{rsh}. @item nntp-end-of-line @@ -7315,13 +8432,6 @@ @vindex nntp-prepare-server-hook A hook run before attempting to connect to an @sc{nntp} server. -@item nntp-async-number -@vindex nntp-async-number -How many articles should be pre-fetched when in asynchronous mode. If -this variable is @code{t}, @code{nntp} will pre-fetch all the articles -that it can without bound. If it is @code{nil}, no pre-fetching will be -made. - @item nntp-warn-about-losing-connection @vindex nntp-warn-about-losing-connection If this variable is non-@code{nil}, some noise will be made when a @@ -7336,8 +8446,9 @@ @cindex news spool Subscribing to a foreign group from the local spool is extremely easy, -and might be useful, for instance, to speed up reading groups like -@samp{alt.binaries.pictures.furniture}. +and might be useful, for instance, to speed up reading groups that +contain very big articles---@samp{alt.binaries.pictures.furniture}, for +instance. Anyways, you just specify @code{nnspool} as the method and @samp{} (or anything else) as the address. @@ -7418,6 +8529,7 @@ * Mail and Procmail:: Reading mail groups that procmail create. * Incorporating Old Mail:: What about the old mail you have? * Expiring Mail:: Getting rid of unwanted mail. +* Washing Mail:: Removing gruft from the mail you get. * Duplicates:: Dealing with duplicated mail. * Not Reading Mail:: Using mail backends for reading other files. * Choosing a Mail Backend:: Gnus can read a variety of mail formats. @@ -7449,12 +8561,12 @@ @lisp (setq nnmail-split-methods - '(("junk" "^From:.*Lars Ingebrigtsen") - ("crazy" "^Subject:.*die\\|^Organization:.*flabby") - ("other" ""))) -@end lisp - -This will result in three new mail groups being created: + '(("junk" "^From:.*Lars Ingebrigtsen") + ("crazy" "^Subject:.*die\\|^Organization:.*flabby") + ("other" ""))) +@end lisp + +This will result in three new @code{nnml} mail groups being created: @samp{nnml:junk}, @samp{nnml:crazy}, and @samp{nnml:other}. All the mail that doesn't fit into the first two groups will be placed in the latter group. @@ -7486,14 +8598,21 @@ element is a regular expression used on the header of each mail to determine if it belongs in this mail group. +If the first element is the special symbol @code{junk}, then messages +that match the regexp will disappear into the aether. Use with +extreme caution. + The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as the argument. It should return a non-@code{nil} value if it thinks that the mail belongs in that group. The last of these groups should always be a general one, and the regular -expression should @emph{always} be @samp{} so that it matches any -mails that haven't been matched by any of the other regexps. +expression should @emph{always} be @samp{} so that it matches any mails +that haven't been matched by any of the other regexps. (These rules are +processed from the beginning of the alist toward the end. The first +rule to make a match will "win", unless you have crossposting enabled. +In that case, all matching rules will "win".) If you like to tinker with this yourself, you can set this variable to a function of your choice. This function will be called without any @@ -7521,6 +8640,11 @@ @code{nnmail-crosspost-link-function} to @code{copy-file}. (This variable is @code{add-name-to-file} by default.) +@kindex M-x nnmail-split-history +@kindex nnmail-split-history +If you wish to see where the previous mail split put the messages, you +can use the @kbd{M-x nnmail-split-history} command. + Gnus gives you all the opportunity you could possibly want for shooting yourself in the foot. Let's say you create a group that will contain all the mail you get from your boss. And then you accidentally @@ -7565,6 +8689,12 @@ @code{t} and be prompted for the password, or set @code{nnmail-pop-password} to the password itself. +@code{nnmail-spool-file} can also be a list of mailboxes. + +Your Emacs has to have been configured with @samp{--with-pop} before +compilation. This is the default, but some installations have it +switched off. + When you use a mail backend, Gnus will slurp all your mail from your inbox and plonk it down in your home directory. Gnus doesn't move any mail if you're not using a mail backend---you have to do a lot of magic @@ -7593,6 +8723,17 @@ This is run in a buffer that holds all the new incoming mail, and can be used for, well, anything, really. +@vindex nnmail-split-hook +@item nnmail-split-hook +@findex article-decode-rfc1522 +@findex RFC1522 decoding +Hook run in the buffer where the mail headers of each message is kept +just before the splitting based on these headers is done. The hook is +free to modify the buffer contents in any way it sees fit---the buffer +is discarded after the splitting has been done, and no changes performed +in the buffer will show up in any files. @code{gnus-article-decode-rfc1522} +is one likely function to add to this hook. + @vindex nnmail-pre-get-new-mail-hook @vindex nnmail-post-get-new-mail-hook @item nnmail-pre-get-new-mail-hook @@ -7624,6 +8765,10 @@ This program is executed to move mail from the user's inbox to her home directory. The default is @samp{movemail}. +This can also be a function. In that case, the function will be called +with two parameters -- the name of the inbox, and the file to be moved +to. + @item nnmail-delete-incoming @vindex nnmail-delete-incoming @cindex incoming mail files @@ -7632,6 +8777,15 @@ file after splitting mail into the proper groups. This is @code{nil} by default for reasons of security. +@c Since Red Gnus is an alpha release, it is to be expected to lose mail. +(No Gnus release since (ding) Gnus 0.10 (or something like that) have +lost mail, I think, but that's not the point. (Except certain versions +of Red Gnus.)) By not deleting the Incoming* files, one can be sure to +not lose mail -- if Gnus totally whacks out, one can always recover what +was lost. + +Delete the @file{Incoming*} files at will. + @item nnmail-use-long-file-names @vindex nnmail-use-long-file-names If non-@code{nil}, the mail backends will use long file and directory @@ -7657,7 +8811,7 @@ If the rather simple, standard method for specifying how to split mail doesn't allow you to do what you want, you can set @code{nnmail-split-methods} to @code{nnmail-split-fancy}. Then you can -play with the @code{nnmail-split-fancy} variable. +play with the @code{nnmail-split-fancy} variable. Let's look at an example value of this variable first: @@ -7678,49 +8832,71 @@ ;; People... (any "larsi@@ifi\\.uio\\.no" "people.Lars Magne Ingebrigtsen")) ;; Unmatched mail goes to the catch all group. - "misc.misc"))") + "misc.misc") @end lisp This variable has the format of a @dfn{split}. A split is a (possibly) recursive structure where each split may contain other splits. Here are -the four possible split syntaxes: - -@table @dfn - -@item GROUP -If the split is a string, that will be taken as a group name. - -@item (FIELD VALUE SPLIT) -If the split is a list, and the first element is a string, then that -means that if header FIELD (a regexp) contains VALUE (also a regexp), -then store the message as specified by SPLIT. - -@item (| SPLIT...) -If the split is a list, and the first element is @code{|} (vertical -bar), then process each SPLIT until one of them matches. A SPLIT is -said to match if it will cause the mail message to be stored in one or -more groups. - -@item (& SPLIT...) -If the split is a list, and the first element is @code{&}, then process -all SPLITs in the list. -@end table - -In these splits, FIELD must match a complete field name. VALUE must -match a complete word according to the fundamental mode syntax table. -You can use @code{.*} in the regexps to match partial field names or -words. +the five possible split syntaxes: + +@enumerate + +@item +@samp{group}: If the split is a string, that will be taken as a group name. + +@item +@var{(FIELD VALUE SPLIT)}: If the split is a list, and the first +element is a string, then that means that if header FIELD (a regexp) +contains VALUE (also a regexp), then store the message as specified by +SPLIT. + +@item +@var{(| SPLIT...)}: If the split is a list, and the first element is +@code{|} (vertical bar), then process each SPLIT until one of them +matches. A SPLIT is said to match if it will cause the mail message to +be stored in one or more groups. + +@item +@var{(& SPLIT...)}: If the split is a list, and the first element is +@code{&}, then process all SPLITs in the list. + +@item +@code{junk}: If the split is the symbol @code{junk}, then don't save +this message anywhere. + +@item +@var{(: function arg1 arg2 ...)}: If the split is a list, and the first +element is @code{:}, then the second element will be called as a +function with @var{args} given as arguments. The function should return +a SPLIT. + +@end enumerate + +In these splits, @var{FIELD} must match a complete field name. +@var{VALUE} must match a complete word according to the fundamental mode +syntax table. You can use @code{.*} in the regexps to match partial +field names or words. In other words, all @var{VALUE}'s are wrapped in +@samp{\<} and @samp{\>} pairs. @vindex nnmail-split-abbrev-alist -FIELD and VALUE can also be lisp symbols, in that case they are expanded -as specified by the variable @code{nnmail-split-abbrev-alist}. This is -an alist of cons cells, where the car of the cells contains the key, and -the cdr contains a string. +@var{FIELD} and @var{VALUE} can also be lisp symbols, in that case they +are expanded as specified by the variable +@code{nnmail-split-abbrev-alist}. This is an alist of cons cells, where +the car of the cells contains the key, and the cdr contains a string. @vindex nnmail-split-fancy-syntax-table @code{nnmail-split-fancy-syntax-table} is the syntax table in effect when all this splitting is performed. +If you want to have Gnus create groups dynamically based on some +information in the headers, you can say things like: + +@example +(any "debian-\(\\w*\\)@@lists.debian.org" "mail.debian.\\1") +@end example + +That is, do @code{replace-match}-like substitions in the group names. + @node Mail and Procmail @subsection Mail and Procmail @@ -7783,6 +8959,20 @@ ever expiring the final article in a mail newsgroup. This is quite, quite important. +Here's an example setup: The incoming spools are located in +@file{~/incoming/} and have @samp{""} as suffixes (i. e., the incoming +spool files have the same names as the equivalent groups). The +@code{nnfolder} backend is to be used as the mail interface, and the +@code{nnfolder} directory is @file{~/fMail/}. + +@lisp +(setq nnfolder-directory "~/fMail/") +(setq nnmail-spool-file 'procmail) +(setq nnmail-procmail-directory "~/incoming/") +(setq gnus-secondary-select-methods '((nnfolder ""))) +(setq nnmail-procmail-suffix "") +@end lisp + @node Incorporating Old Mail @subsection Incorporating Old Mail @@ -7865,6 +9055,12 @@ articles that are marked as expirable have an @samp{E} in the first column in the summary buffer. +Note that making a group auto-expirable don't mean that all read +articles are expired---only the articles that are marked as expirable +will be expired. Also note the using the @kbd{d} command won't make +groups expirable---only semi-automatic marking of articles as read will +mark the articles as expirable in auto-expirable groups. + Let's say you subscribe to a couple of mailing lists, and you want the articles you have read to disappear after a while: @@ -7876,6 +9072,10 @@ Another way to have auto-expiry happen is to have the element @code{auto-expire} in the group parameters of the group. +If you use adaptive scoring (@pxref{Adaptive Scoring}) and +auto-expiring, you'll have problems. Auto-expiring and adaptive scoring +doesn't really mix very well. + @vindex nnmail-expiry-wait The @code{nnmail-expiry-wait} variable supplies the default time an expirable article has to live. The default is seven days. @@ -7931,6 +9131,92 @@ @emph{man}! Or a @emph{woman}! Whatever you feel more comfortable with! So there! +Most people make most of their mail groups total-expirable, though. + + +@node Washing Mail +@subsection Washing Mail +@cindex mail washing +@cindex list server brain damage +@cindex incoming mail treatment + +Mailers and list servers are notorious for doing all sorts of really, +really stupid things with mail. ``Hey, RFC822 doesn't explicitly +prohibit us from adding the string @code{wE aRe ElItE!!!!!1!!} to the +end of all lines passing through our server, so let's do that!!!!1!'' +Yes, but RFC822 wasn't designed to be read by morons. Things that were +considered to be self-evident were not discussed. So. Here we are. + +Case in point: The German version of Microsoft Exchange adds @samp{AW: +} to the subjects of replies instead of @samp{Re: }. I could pretend to +be shocked and dismayed by this, but I haven't got the energy. It is to +laugh. + +Gnus provides a plethora of functions for washing articles while +displaying them, but it might be nicer to do the filtering before +storing the mail to disc. For that purpose, we have three hooks and +various functions that can be put in these hooks. + +@table @code +@item nnmail-prepare-incoming-hook +@vindex nnmail-prepare-incoming-hook +This hook is called before doing anything with the mail and is meant for +grand, sweeping gestures. Functions to be used include: + +@table @code +@item nnheader-ms-strip-cr +@findex nnheader-ms-strip-cr +Remove trailing carriage returns from each line. This is default on +Emacs running on MS machines. + +@end table + +@item nnmail-prepare-incoming-header-hook +@vindex nnmail-prepare-incoming-header-hook +This hook is called narrowed to each header. It can be used when +cleaning up the headers. Functions that can be used include: + +@table @code +@item nnmail-remove-leading-whitespace +@findex nnmail-remove-leading-whitespace +Clear leading white space that ``helpful'' listservs have added to the +headers too make them look nice. Aaah. + +@item nnmail-remove-list-identifiers +@findex nnmail-remove-list-identifiers +Some list servers add an identifier---for example, @samp{(idm)}---to the +beginning of all @code{Subject} headers. I'm sure that's nice for +people who use stone age mail readers. This function will remove +strings that match the @code{nnmail-list-identifiers} regexp, which can +also be a list of regexp. + +For instance, if you want to remove the @samp{(idm)} and the +@samp{nagnagnag} identifiers: + +@lisp +(setq nnmail-list-identifiers + '("(idm)" "nagnagnag")) +@end lisp + +@item nnmail-remove-tabs +@findex nnmail-remove-tabs +Translate all @samp{TAB} characters into @samp{SPACE} characters. + +@end table + +@item nnmail-prepare-incoming-message-hook +@vindex nnmail-prepare-incoming-message-hook +This hook is called narrowed to each message. Functions to be used +include: + +@table @code +@item article-de-quoted-unreadable +@findex article-de-quoted-unreadable +Decode Quoted Readable encoding. + +@end table +@end table + @node Duplicates @subsection Duplicates @@ -7942,7 +9228,7 @@ If you are a member of a couple of mailing list, you will sometime receive two copies of the same mail. This can be quite annoying, so @code{nnmail} checks for and treats any duplicates it might find. To do -this, it keeps a cache of old @code{Message-ID}s - +this, it keeps a cache of old @code{Message-ID}s--- @code{nnmail-message-id-cache-file}, which is @file{~/.nnmail-cache} by default. The approximate maximum number of @code{Message-ID}s stored there is controlled by the @code{nnmail-message-id-cache-length} @@ -8161,7 +9447,9 @@ you can do a complete update by typing @kbd{M-x nnml-generate-nov-databases}. This command will trawl through the entire @code{nnml} hierarchy, looking at each and every article, so it -might take a while to complete. +might take a while to complete. A better interface to this +functionality can be found in the server buffer (@pxref{Server +Commands}). @node MH Spool @@ -8243,10 +9531,12 @@ newsgroups. @menu -* Directory Groups:: You can read a directory as if it was a newsgroup. -* Anything Groups:: Dired? Who needs dired? -* Document Groups:: Single files can be the basis of a group. -* SOUP:: Reading @sc{SOUP} packets ``offline''. +* Directory Groups:: You can read a directory as if it was a newsgroup. +* Anything Groups:: Dired? Who needs dired? +* Document Groups:: Single files can be the basis of a group. +* SOUP:: Reading @sc{SOUP} packets ``offline''. +* Web Searches:: Creating groups from articles that match a string. +* Mail-To-News Gateways:: Posting articles via mail-to-news gateways. @end menu @@ -8264,9 +9554,10 @@ didn't think much about it---a backend to read directories. Big deal. @code{ange-ftp} changes that picture dramatically. For instance, if you -enter @file{"/ftp.hpc.uh.edu:/pub/emacs/ding-list/"} as the the -directory name, ange-ftp will actually allow you to read this directory -over at @samp{sina} as a newsgroup. Distributed news ahoy! +enter the @code{ange-ftp} file name +@file{/ftp.hpc.uh.edu:/pub/emacs/ding-list/} as the the directory name, +@code{ange-ftp} will actually allow you to read this directory over at +@samp{sina} as a newsgroup. Distributed news ahoy! @code{nndir} will use @sc{nov} files if they are present. @@ -8292,7 +9583,7 @@ forgetting. @code{nneething} does this in a two-step process. First, it snoops each file in question. If the file looks like an article (i.e., the first few lines look like headers), it will use this as the head. -If this is just some arbitrary file without a head (eg. a C source +If this is just some arbitrary file without a head (e.g. a C source file), @code{nneething} will cobble up a header out of thin air. It will use file ownership, name and date and do whatever it can with these elements. @@ -8399,11 +9690,12 @@ new & spiffy Gnus mail backend, @code{nndoc} can probably help you with that. Say you have an old @file{RMAIL} file with mail that you now want to split into your new @code{nnml} groups. You look at that file using -@code{nndoc}, set the process mark on all the articles in the buffer -(@kbd{M P b}, for instance), and then re-spool (@kbd{B r}) using -@code{nnml}. If all goes well, all the mail in the @file{RMAIL} file is -now also stored in lots of @code{nnml} directories, and you can delete -that pesky @file{RMAIL} file. If you have the guts! +@code{nndoc} (using the @kbd{G f} command in the group buffer +(@pxref{Foreign Groups})), set the process mark on all the articles in +the buffer (@kbd{M P b}, for instance), and then re-spool (@kbd{B r}) +using @code{nnml}. If all goes well, all the mail in the @file{RMAIL} +file is now also stored in lots of @code{nnml} directories, and you can +delete that pesky @file{RMAIL} file. If you have the guts! Virtual server variables: @@ -8421,6 +9713,133 @@ and @code{news}. @end table +@menu +* Document Server Internals:: How to add your own document types. +@end menu + + +@node Document Server Internals +@subsubsection Document Server Internals + +Adding new document types to be recognized by @code{nndoc} isn't +difficult. You just have to whip up a definition of what the document +looks like, write a predicate function to recognize that document type, +and then hook into @code{nndoc}. + +First, here's an example document type definition: + +@example +(mmdf + (article-begin . "^\^A\^A\^A\^A\n") + (body-end . "^\^A\^A\^A\^A\n")) +@end example + +The definition is simply a unique @dfn{name} followed by a series of +regexp pseudo-variable settings. Below are the possible +variables---don't be daunted by the number of variables; most document +types can be defined with very few settings: + +@table @code +@item first-article +If present, @code{nndoc} will skip past all text until it finds +something that match this regexp. All text before this will be +totally ignored. + +@item article-begin +This setting has to be present in all document type definitions. It +says what the beginning of each article looks like. + +@item head-begin-function +If present, this should be a function that moves point to the head of +the article. + +@item nndoc-head-begin +If present, this should be a regexp that matches the head of the +article. + +@item nndoc-head-end +This should match the end of the head of the article. It defaults to +@samp{^$}---the empty line. + +@item body-begin-function +If present, this function should move point to the beginning of the body +of the article. + +@item body-begin +This should match the beginning of the body of the article. It defaults +to @samp{^\n}. + +@item body-end-function +If present, this function should move point to the end of the body of +the article. + +@item body-end +If present, this should match the end of the body of the article. + +@item nndoc-file-end +If present, this should match the end of the file. All text after this +regexp will be totally ignored. + +@end table + +So, using these variables @code{nndoc} is able to dissect a document +file into a series of articles, each with a head and a body. However, a +few more variables are needed since not all document types are all that +news-like---variables needed to transform the head or the body into +something that's palatable for Gnus: + +@table @code +@item prepare-body-function +If present, this function will be called when requesting an article. It +will be called with point at the start of the body, and is useful if the +document has encoded some parts of its contents. + +@item article-transform-function +If present, this function is called when requesting an article. It's +meant to be used how more wide-ranging transformation of both head and +body of the article. + +@item generate-head-function +If present, this function is called to generate a head that Gnus can +understand. It is called with the article number as a parameter, and is +expected to generate a nice head for the article in question. It is +called when requesting the headers of all articles. + +@end table + +Let's look at the most complicated example I can come up with---standard +digests: + +@example +(standard-digest + (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) + (article-begin . ,(concat "\n\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)) +@end example + +We see that all text before a 70-width line of dashes is ignored; all +text after a line that starts with that @samp{^End of} is also ignored; +each article begins with a 30-width line of dashes; the line separating +the head from the body may contain a single space; and that the body is +run through @code{nndoc-unquote-dashes} before being delivered. + +To hook your own document definition into @code{nndoc}, use the +@code{nndoc-add-type} function. It takes two parameters---the first is +the definition itself and the second (optional) parameter says where in +the document type definition alist to put this definition. The alist is +traversed sequentially, and @code{nndoc-TYPE-type-p} is called for each +type. So @code{nndoc-mmdf-type-p} is called to see whether a document +is of @code{mmdf} type, and so on. These type predicates should return +@code{nil} if the document is not of the correct type; @code{t} if it is +of the correct type; and a number if the document might be of the +correct type. A high number means high probability; a low number means +low probability with @samp{0} being the lowest legal number. + @node SOUP @subsection SOUP @@ -8444,12 +9863,45 @@ and mail from servers to home machines and back again. It can be a bit fiddly. +First some terminology: + +@table @dfn + +@item server +This is the machine that is connected to the outside world and where you +get news and/or mail from. + +@item home machine +This is the machine that you want to do the actual reading and responding +on. It is typically not connected to the rest of the world in any way. + +@item packet +Something that contains messages and/or commands. There are two kinds +of packets: + +@table @dfn +@item message packets +These are packets made at the server, and typically contains lots of +messages for you to read. These are called @file{SoupoutX.tgz} by +default, where @var{X} is a number. + +@item response packets +These are packets made at the home machine, and typically contains +replies that you've written. These are called @file{SoupinX.tgz} by +default, where @var{X} is a number. + +@end table + +@end table + + @enumerate @item You log in on the server and create a @sc{soup} packet. You can either -use a dedicated @sc{soup} thingie, or you can use Gnus to create the -packet with the @kbd{O s} command. +use a dedicated @sc{soup} thingie (like the @code{awk} program), or you +can use Gnus to create the packet with its @sc{soup} commands (@kbd{O +s} and/or @kbd{G s b}; and then @kbd{G s p}) (@pxref{SOUP Commands}). @item You transfer the packet home. Rail, boat, car or modem will do fine. @@ -8458,11 +9910,12 @@ You put the packet in your home directory. @item -You fire up Gnus using the @code{nnsoup} backend as the native server. +You fire up Gnus on your home machine using the @code{nnsoup} backend as +the native or secondary server. @item You read articles and mail and answer and followup to the things you -want. +want (@pxref{SOUP Replies}). @item You do the @kbd{G s r} command to pack these replies into a @sc{soup} @@ -8492,6 +9945,8 @@ @node SOUP Commands @subsubsection SOUP Commands +These are commands for creating and manipulating @sc{soup} packets. + @table @kbd @item G s b @kindex G s b (Group) @@ -8503,7 +9958,7 @@ @item G s w @kindex G s w (Group) @findex gnus-soup-save-areas -Save all data files (@code{gnus-soup-save-areas}). +Save all @sc{soup} data files (@code{gnus-soup-save-areas}). @item G s s @kindex G s s (Group) @@ -8526,7 +9981,7 @@ @findex gnus-soup-add-article This summary-mode command adds the current article to a @sc{soup} packet (@code{gnus-soup-add-article}). It understands the process/prefix -convention. +convention (@pxref{Process/Prefix}). @end table @@ -8544,7 +9999,7 @@ @item gnus-soup-replies-directory @vindex gnus-soup-replies-directory This is what Gnus will use as a temporary directory while sending our -reply packets. The default is @file{~/SoupBrew/SoupReplies/}. +reply packets. @file{~/SoupBrew/SoupReplies/} is the default. @item gnus-soup-prefix-file @vindex gnus-soup-prefix-file @@ -8656,8 +10111,8 @@ In specific, this is what it does: @lisp -(setq gnus-inews-article-function 'nnsoup-request-post) -(setq send-mail-function 'nnsoup-request-mail) +(setq message-send-news-function 'nnsoup-request-post) +(setq message-send-mail-function 'nnsoup-request-mail) @end lisp And that's it, really. If you only want news to go into the @sc{soup} @@ -8665,6 +10120,146 @@ @sc{soup}ed you use the second. +@node Web Searches +@subsection Web Searches +@cindex nnweb +@cindex DejaNews +@cindex Alta Vista +@cindex InReference +@cindex Usenet searches +@cindex searching the Usenet + +It's, like, too neat to search the Usenet for articles that match a +string, but it, like, totally @emph{sucks}, like, totally, to use one of +those, like, Web browsers, and you, like, have to, rilly, like, look at +the commercials, so, like, with Gnus you can do @emph{rad}, rilly, +searches without having to use a browser. + +The @code{nnweb} backend allows an easy interface to the mighty search +engine. You create an @code{nnweb} group, enter a search pattern, and +then enter the group and read the articles like you would any normal +group. The @kbd{G w} command in the group buffer (@pxref{Foreign +Groups}) will do this in an easy-to-use fashion. + +@code{nnweb} groups don't really lend themselves to being solid +groups---they have a very fleeting idea of article numbers. In fact, +each time you enter an @code{nnweb} group (not even changing the search +pattern), you are likely to get the articles ordered in a different +manner. Not even using duplicate suppression (@code{Duplicate +Suppression}) will help, since @code{nnweb} doesn't even know the +@code{Message-ID} of the articles before reading them using some search +engines (DejaNews, for instance). The only possible way to keep track +of which articles you've read is by scoring on the @code{Date} +header---mark all articles that were posted before the last date you +read the group as read. + +If the search engine changes its output substantially, @code{nnweb} +won't be able to parse it and will fail. One could hardly fault the Web +providers if they were to do this---their @emph{raison d'être} is to +make money off of advertisements, not to provide services to the +community. Since @code{nnweb} washes the ads off all the articles, one +might think that the providers might be somewhat miffed. We'll see. + +You must have the @code{url} and @code{w3} package installed to be able +to use @code{nnweb}. + +Virtual server variables: + +@table @code +@item nnweb-type +@vindex nnweb-type +What search engine type is being used. The currently supported types +are @code{dejanews}, @code{altavista} and @code{reference}. + +@item nnweb-search +@vindex nnweb-search +The search string to feed to the search engine. + +@item nnweb-max-hits +@vindex nnweb-max-hits +Advisory maximum number of hits per search to display. The default is +100. + +@item nnweb-type-definition +@vindex nnweb-type-definition +Type-to-definition alist. This alist says what @code{nnweb} should do +with the various search engine types. The following elements must be +present: + +@table @code +@item article +Function to decode the article and provide something that Gnus +understands. + +@item map +Function to create an article number to message header and URL alist. + +@item search +Function to send the search string to the search engine. + +@item address +The address the aforementioned function should send the search string +to. + +@item id +Format string URL to fetch an article by @code{Message-ID}. +@end table + +@end table + + + +@node Mail-To-News Gateways +@subsection Mail-To-News Gateways +@cindex mail-to-news gateways +@cindex gateways + +If your local @code{nntp} server doesn't allow posting, for some reason +or other, you can post using one of the numerous mail-to-news gateways. +The @code{nngateway} backend provides the interface. + +Note that you can't read anything from this backend---it can only be +used to post with. + +Server variables: + +@table @code +@item nngateway-address +@vindex nngateway-address +This is the address of the mail-to-news gateway. + +@item nngateway-header-transformation +@vindex nngateway-header-transformation +News headers have often have to be transformed in some odd way or other +for the mail-to-news gateway to accept it. This variable says what +transformation should be called, and defaults to +@code{nngateway-simple-header-transformation}. The function is called +narrowed to the headers to be transformed and with one parameter---the +gateway address. + +This default function just inserts a new @code{To} header based on the +@code{Newsgroups} header and the gateway address---an article with this +@code{Newsgroups} header: + +@example +Newsgroups: alt.religion.emacs +@end example + +will get this @code{From} header inserted: + +@example +To: alt-religion-emacs@@GATEWAY +@end example + +@end table + +So, to use this, simply say something like: + +@lisp +(setq gnus-post-method '(nngateway "GATEWAY.ADDRESS")) +@end lisp + + @node Combined Groups @section Combined Groups @@ -8825,13 +10420,17 @@ * Score Variables:: Customize your scoring. (My, what terminology). * Score File Format:: What a score file may contain. * Score File Editing:: You can edit score files by hand as well. -* Adaptive Scoring:: Big Sister Gnus @emph{knows} what you read. +* Adaptive Scoring:: Big Sister Gnus knows what you read. +* Home Score File:: How to say where new score entries are to go. * Followups To Yourself:: Having Gnus notice when people answer you. * Scoring Tips:: How to score effectively. * Reverse Scoring:: That problem child of old is not problem. * Global Score Files:: Earth-spanning, ear-splitting score files. * Kill Files:: They are still here, but they can be ignored. +* Converting Kill Files:: Translating kill files to score files. * GroupLens:: Getting predictions on what you like to read. +* Advanced Scoring:: Using logical expressions to build score rules. +* Score Decays:: It can be useful to let scores wither away. @end menu @@ -8847,7 +10446,7 @@ The current score file is by default the group's local score file, even if no such score file actually exists. To insert score commands into -some other score file (eg. @file{all.SCORE}), you must first make this +some other score file (e.g. @file{all.SCORE}), you must first make this score file the current one. General score commands that don't actually change the score file: @@ -8872,7 +10471,7 @@ (@code{gnus-score-find-trace}). @item V R -@cindex V R (Summary) +@kindex V R (Summary) @findex gnus-summary-rescore Run the current summary through the scoring process (@code{gnus-summary-rescore}). This might be useful if you're playing @@ -8907,7 +10506,7 @@ @item V F @kindex V F (Summary) @findex gnus-score-flush-cache -Flush the score cahe (@code{gnus-score-flush-cache}). This is useful +Flush the score cache (@code{gnus-score-flush-cache}). This is useful after editing score files. @item V C @@ -9154,6 +10753,12 @@ @vindex gnus-summary-default-score Default score of an article, which is 0 by default. +@item gnus-summary-expunge-below +@vindex gnus-summary-expunge-below +Don't display the summary lines of articles that have scores lower than +this variable. This is @code{nil} by default, which means that no +articles will be hidden. + @item gnus-score-over-mark @vindex gnus-score-over-mark Mark (in the third column) used for articles with a score over the @@ -9179,7 +10784,7 @@ @item gnus-score-find-bnews @findex gnus-score-find-bnews Apply all score files that match, using bnews syntax. This is the -default. For instance, if the current group is @samp{gnu.emacs.gnus}, +default. If the current group is @samp{gnu.emacs.gnus}, for instance, @file{all.emacs.all.SCORE}, @file{not.alt.all.SCORE} and @file{gnu.all.SCORE} would all apply. In short, the instances of @samp{all} in the score file names are translated into @samp{.*}, and @@ -9188,12 +10793,16 @@ This means that if you have some score entries that you want to apply to all groups, then you put those entries in the @file{all.SCORE} file. +The score files are applied in a semi-random order, although Gnus will +try to apply the more general score files before the more specific score +files. It does this by looking at the number of elements in the score +file names---discarding the @samp{all} elements. + @item gnus-score-find-hierarchical @findex gnus-score-find-hierarchical Apply all score files from all the parent groups. This means that you -can't have score files like @file{all.SCORE} or @file{all.emacs.SCORE}, -but you can have @file{SCORE}, @file{comp.SCORE} and -@file{comp.emacs.SCORE}. +can't have score files like @file{all.SCORE}, but you can have +@file{SCORE}, @file{comp.SCORE} and @file{comp.emacs.SCORE}. @end table This variable can also be a list of functions. In that case, all these @@ -9317,40 +10926,69 @@ @table @dfn @item From, Subject, References, Xref, Message-ID -For most header types, there are the @code{r} and @code{R} (regexp) as -well as @code{s} and @code{S} (substring) types and @code{e} and -@code{E} (exact match) types. If this element is not present, Gnus will -assume that substring matching should be used. @code{R} and @code{S} -differ from the other two in that the matches will be done in a -case-sensitive manner. All these one-letter types are really just -abbreviations for the @code{regexp}, @code{string} and @code{exact} -types, which you can use instead, if you feel like. +For most header types, there are the @code{r} and @code{R} (regexp), as +well as @code{s} and @code{S} (substring) types, and @code{e} and +@code{E} (exact match), and @code{w} (word match) types. If this +element is not present, Gnus will assume that substring matching should +be used. @code{R}, @code{S}, and @code{E} differ from the others in +that the matches will be done in a case-sensitive manner. All these +one-letter types are really just abbreviations for the @code{regexp}, +@code{string}, @code{exact}, and @code{word} types, which you can use +instead, if you feel like. @item Lines, Chars These two headers use different match types: @code{<}, @code{>}, -@code{=}, @code{>=} and @code{<=}. +@code{=}, @code{>=} and @code{<=}. When matching on @code{Lines}, be +careful because some backends (like @code{nndir}) do not generate +@code{Lines} header, so every article ends up being marked as having 0 +lines. This can lead to strange results if you happen to lower score of +the articles with few lines. @item Date -For the Date header we have three match types: @code{before}, @code{at} -and @code{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.) +For the Date header we have three kinda silly match types: +@code{before}, @code{at} and @code{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.) + +@cindex ISO8601 +@cindex date +A more useful match type is @code{regexp}. With it, you can match the +date string using a regular expression. The date is normalized to +ISO8601 compact format first---@samp{YYYYMMDDTHHMMSS}. If you want to +match all articles that have been posted on April 1st in every year, you +could use @samp{....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?) @item Head, Body, All These three match keys use the same match types as the @code{From} (etc) header uses. @item Followup -This match key will add a score entry on all articles that followup to -some author. Uses the same match types as the @code{From} header uses. +This match key is somewhat special, in that it will match the +@code{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. Uses the same match types as the @code{From} header +uses. @item Thread -This match key will add a score entry on all articles that are part of -a thread. Uses the same match types as the @code{References} header -uses. +This match key works along the same lines as the @code{Followup} match +key. If you say that you want to score on a (sub-)thread that is +started by an article with a @code{Message-ID} @var{X}, then you add a +@samp{thread} match. This will add a new @samp{thread} match for each +article that has @var{X} in its @code{References} header. (These new +@samp{thread} matches will use the @code{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 @code{References} headers. Note that using this may lead to +undeterministic scores of the articles in the thread. @end table @end enumerate @@ -9379,7 +11017,7 @@ this one was. @item exclude-files -The clue of this entry should be any number of files. This files will +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. @@ -9400,8 +11038,8 @@ You can do this with the following two score file entries: @example - (orphan -500) - (mark-and-expunge -100) + (orphan -500) + (mark-and-expunge -100) @end example When you enter the group the first time, you will only see the new @@ -9501,7 +11139,10 @@ article, you leave marks behind. On exit from the group, Gnus can sniff these marks and add score elements depending on what marks it finds. You turn on this ability by setting @code{gnus-use-adaptive-scoring} to -@code{t}. +@code{t} or @code{(line)}. If you want score adaptively on separate +words appearing in the subjects, you should set this variable to +@code{(word)}. If you want to use both adaptive methods, set this +variable to @code{(word line)}. @vindex gnus-default-adaptive-score-alist To give you complete control over the scoring process, you can customize @@ -9544,6 +11185,11 @@ That means that that subject will get a score of ten times -1, which should be, unless I'm much mistaken, -10. +If you have auto-expirable (mail) groups (@pxref{Expiring Mail}), all +the read articles will be marked with the @samp{E} mark. This'll +probably make adaptive scoring slightly impossible, so auto-expiring and +adaptive scoring doesn't really mix very well. + The headers you can score on are @code{from}, @code{subject}, @code{message-id}, @code{references}, @code{xref}, @code{lines}, @code{chars} and @code{date}. In addition, you can score on @@ -9584,6 +11230,134 @@ this variable is @code{nil}, exact matching will always be used to avoid this problem. +@vindex gnus-default-adaptive-word-score-alist +As mentioned above, you can adapt either on individual words or entire +headers. If you adapt on words, the +@code{gnus-default-adaptive-word-score-alist} variable says what score +each instance of a word should add given a mark. + +@lisp +(setq gnus-default-adaptive-word-score-alist + `((,gnus-read-mark . 30) + (,gnus-catchup-mark . -10) + (,gnus-killed-mark . -20) + (,gnus-del-mark . -15))) +@end lisp + +This is the default value. If you have adaption on words enabled, every +word that appears in subjects of articles that are marked with +@code{gnus-read-mark} will result in a score rule that increase the +score with 30 points. + +@vindex gnus-default-ignored-adaptive-words +@vindex gnus-ignored-adaptive-words +Words that appear in the @code{gnus-default-ignored-adaptive-words} list +will be ignored. If you wish to add more words to be ignored, use the +@code{gnus-ignored-adaptive-words} list instead. + +@vindex gnus-adaptive-word-syntax-table +When the scoring is done, @code{gnus-adaptive-word-syntax-table} is the +syntax table in effect. It is similar to the standard syntax table, but +it considers numbers to be non-word-constituent characters. + +After using this scheme for a while, it might be nice to write a +@code{gnus-psychoanalyze-user} command to go through the rules and see +what words you like and what words you don't like. Or perhaps not. + +Note that the adaptive word scoring thing is highly experimental and is +likely to change in the future. Initial impressions seem to indicate +that it's totally useless as it stands. Some more work (involving more +rigorous statistical methods) will have to be done to make this useful. + + +@node Home Score File +@section Home Score File + +The score file where new score file entries will go is called the +@dfn{home score file}. This is normally (and by default) the score file +for the group itself. For instance, the home score file for +@samp{gnu.emacs.gnus} is @file{gnu.emacs.gnus.SCORE}. + +However, this may not be what you want. It is often convenient to share +a common home score file among many groups---all @samp{emacs} groups +could perhaps use the same home score file. + +@vindex gnus-home-score-file +The variable that controls this is @code{gnus-home-score-file}. It can +be: + +@enumerate +@item +A string. Then this file will be used as the home score file for all +groups. + +@item +A function. The result of this function will be used as the home score +file. The function will be called with the name of the group as the +parameter. + +@item +A list. The elements in this list can be: + +@enumerate +@item +@var{(regexp file-name)}. If the @var{regexp} matches the group name, +the @var{file-name} will will be used as the home score file. + +@item +A function. If the function returns non-nil, the result will be used as +the home score file. + +@item +A string. Use the string as the home score file. +@end enumerate + +The list will be traversed from the beginning towards the end looking +for matches. + +@end enumerate + +So, if you want to use just a single score file, you could say: + +@lisp +(setq gnus-home-score-file + "my-total-score-file.SCORE") +@end lisp + +If you want to use @file{gnu.SCORE} for all @samp{gnu} groups and +@file{rec.SCORE} for all @samp{rec} groups (and so on), you can say: + +@lisp +(setq gnus-home-score-file + 'gnus-hierarchial-home-score-file) +@end lisp + +This is a ready-made function provided for your convenience. + +If you want to have one score file for the @samp{emacs} groups and +another for the @samp{comp} groups, while letting all other groups use +their own home score files: + +@lisp +(setq gnus-home-score-file + ;; All groups that match the regexp "\\.emacs" + '("\\.emacs" "emacs.SCORE") + ;; All the comp groups in one score file + ("^comp" "comp.SCORE")) +@end lisp + +@vindex gnus-home-adapt-file +@code{gnus-home-adapt-file} works exactly the same way as +@code{gnus-home-score-file}, but says what the home adaptive score file +is instead. All new adaptive file entries will go into the file +specified by this variable, and the same syntax is allowed. + +In addition to using @code{gnus-home-score-file} and +@code{gnus-home-adapt-file}, you can also use group parameters +(@pxref{Group Parameters}) and topic parameters (@pxref{Topic +Parameters}) to achieve much the same. Group and topic parameters take +precedence over this variable. + @node Followups To Yourself @section Followups To Yourself @@ -9608,9 +11382,31 @@ your own article. @end table -@vindex gnus-inews-article-hook +@vindex message-sent-hook These two functions are both primarily meant to be used in hooks like -@code{message-send-hook}. +@code{message-sent-hook}. + +If you look closely at your own @code{Message-ID}, you'll notice that +the first two or three characters are always the same. Here's two of +mine: + +@example + + +@end example + +So ``my'' ident on this machine is @samp{x6}. This can be +exploited---the following rule will raise the score on all followups to +myself: + +@lisp +("references" + ("" 1000 nil r)) +@end lisp + +Whether it's the first two or first three characters that are ``yours'' +is system-dependent. + @node Scoring Tips @section Scoring Tips @@ -9697,9 +11493,9 @@ or each score file directory. Gnus will decide by itself what score files are applicable to which group. -Say you want to use all score files in the -@file{/ftp@@ftp.some-where:/pub/score} directory and the single score -file @file{/ftp@@ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE}: +Say you want to use the score file +@file{/ftp@@ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE} and +all score files in the @file{/ftp@@ftp.some-where:/pub/score} directory: @lisp (setq gnus-global-score-files @@ -9770,7 +11566,7 @@ sort of primitive hook function to be run on group entry, even though that isn't a very good idea. -XCNormal kill files look like this: +Normal kill files look like this: @lisp (gnus-kill "From" "Lars Ingebrigtsen") @@ -9849,6 +11645,26 @@ @end table +@node Converting Kill Files +@section Converting Kill Files +@cindex kill files +@cindex converting kill files + +If you have loads of old kill files, you may want to convert them into +score files. If they are ``regular'', you can use +the @file{gnus-kill-to-score.el} package; if not, you'll have to do it +by hand. + +The kill to score conversion package isn't included in Gnus by default. +You can fetch it from +@file{http://www.ifi.uio.no/~larsi/ding-other/gnus-kill-to-score}. + +If your old kill files are very complex---if they contain more +non-@code{gnus-kill} forms than not, you'll have to convert them by +hand. Or just let them be as they are. Gnus will still use them as +before. + + @node GroupLens @section GroupLens @cindex GroupLens @@ -9879,8 +11695,9 @@ @subsection Using GroupLens To use GroupLens you must register a pseudonym with your local Better -Bit Bureau (BBB). At the moment the only better bit in town is at -@samp{http://www.cs.umn.edu/Research/GroupLens/bbb.html}. +Bit Bureau (BBB). +@samp{http://www.cs.umn.edu/Research/GroupLens/bbb.html} is the only +better bit in town is at the moment. Once you have registered you'll need to set a couple of variables. @@ -9893,7 +11710,7 @@ @item grouplens-pseudonym @vindex grouplens-pseudonym -This variable should be set to the pseudonum you got when registering +This variable should be set to the pseudonym you got when registering with the Better Bit Bureau. @item grouplens-newsgroups @@ -10026,8 +11843,8 @@ @samp{%U%R%z%l%I%(%[%4L: %-20,20n%]%) %s\n}. @item grouplens-bbb-host -Host running the bbbd server. The default is -@samp{grouplens.cs.umn.edu}. +Host running the bbbd server. @samp{grouplens.cs.umn.edu} is the +default. @item grouplens-bbb-port Port of the host running the bbbd server. The default is 9000. @@ -10044,6 +11861,228 @@ @end table +@node Advanced Scoring +@section Advanced Scoring + +Scoring on Subjects and From headers is nice enough, but what if you're +really interested in what a person has to say only when she's talking +about a particular subject? Or what about if you really don't want to +read what person A has to say when she's following up to person B, but +want to read what she says when she's following up to person C? + +By using advanced scoring rules you may create arbitrarily complex +scoring patterns. + +@menu +* Advanced Scoring Syntax:: A definition. +* Advanced Scoring Examples:: What they look like. +* Advanced Scoring Tips:: Getting the most out of it. +@end menu + + +@node Advanced Scoring Syntax +@subsection Advanced Scoring Syntax + +Ordinary scoring rules have a string as the first element in the rule. +Advanced scoring rules have a list as the first element. The second +element is the score to be applied if the first element evaluated to a +non-@code{nil} value. + +These lists may consist of three logical operators, one redirection +operator, and various match operators. + +Logical operators: + +@table @code +@item & +@itemx and +This logical operator will evaluate each of its arguments until it finds +one that evaluates to @code{false}, and then it'll stop. If all arguments +evaluate to @code{true} values, then this operator will return +@code{true}. + +@item | +@itemx or +This logical operator will evaluate each of its arguments until it finds +one that evaluates to @code{true}. If no arguments are @code{true}, +then this operator will return @code{false}. + +@item ! +@itemx not +@itemx ¬ +This logical operator only takes a single argument. It returns the +inverse of the value of its argument. + +@end table + +There is an @dfn{indirection operator} that will make its arguments +apply to the ancestors of the current article being scored. For +instance, @code{1-} will make score rules apply to the parent of the +current article. @code{2-} will make score fules apply to the +grandparent of the current article. Alternatively, you can write +@code{^^}, where the number of @code{^}s (carets) say how far back into +the ancestry you want to go. + +Finally, we have the match operators. These are the ones that do the +real work. Match operators are header name strings followed by a match +and a match type. A typical match operator looks like @samp{("from" +"Lars Ingebrigtsen" s)}. The header names are the same as when using +simple scoring, and the match types are also the same. + + +@node Advanced Scoring Examples +@subsection Advanced Scoring Examples + +Let's say you want to increase the score of articles written by Lars +when he's talking about Gnus: + +@example +((& + ("from" "Lars Ingebrigtsen") + ("subject" "Gnus")) + 1000) +@end example + +Quite simple, huh? + +When he writes long articles, he sometimes has something nice to say: + +@example +((& + ("from" "Lars Ingebrigtsen") + (| + ("subject" "Gnus") + ("lines" 100 >))) + 1000) +@end example + +However, when he responds to things written by Reig Eigil Logge, you +really don't want to read what he's written: + +@example +((& + ("from" "Lars Ingebrigtsen") + (1- ("from" "Reig Eigir Logge"))) + -100000) +@end example + +Everybody that follows up Redmondo when he writes about disappearing +socks should have their scores raised, but only when they talk about +white socks. However, when Lars talks about socks, it's usually not +very interesting: + +@example +((& + (1- + (& + ("from" "redmondo@@.*no" r) + ("body" "disappearing.*socks" t))) + (! ("from" "Lars Ingebrigtsen")) + ("body" "white.*socks")) + 1000) +@end example + +The possibilities are endless. + + +@node Advanced Scoring Tips +@subsection Advanced Scoring Tips + +The @code{&} and @code{|} logical operators do short-circuit logic. +That is, they stop processing their arguments when it's clear what the +result of the operation will be. For instance, if one of the arguments +of an @code{&} evaluates to @code{false}, there's no point in evaluating +the rest of the arguments. This means that you should put slow matches +(@samp{body}, @code{header}) last and quick matches (@samp{from}, +@samp{subject}) first. + +The indirection arguments (@code{1-} and so on) will make their +arguments work on previous generations of the thread. If you say +something like: + +@example +... +(1- + (1- + ("from" "lars"))) +... +@end example + +Then that means "score on the from header of the grandparent of the +current article". An indirection is quite fast, but it's better to say: + +@example +(1- + (& + ("from" "Lars") + ("subject" "Gnus"))) +@end example + +than it is to say: + +@example +(& + (1- ("from" "Lars")) + (1- ("subject" "Gnus"))) +@end example + + +@node Score Decays +@section Score Decays +@cindex score decays +@cindex decays + +You may find that your scores have a tendency to grow without +bounds, especially if you're using adaptive scoring. If scores get too +big, they lose all meaning---they simply max out and it's difficult to +use them in any sensible way. + +@vindex gnus-decay-scores +@findex gnus-decay-score +@vindex gnus-score-decay-function +Gnus provides a mechanism for decaying scores to help with this problem. +When score files are loaded and @code{gnus-decay-scores} is +non-@code{nil}, Gnus will run the score files through the decaying +mechanism thereby lowering the scores of all non-permanent score rules. +The decay itself if performed by the @code{gnus-score-decay-function} +function, which is @code{gnus-decay-score} by default. Here's the +definition of that function: + +@lisp +(defun gnus-decay-score (score) + (floor + (- score + (* (if (< score 0) 1 -1) + (min score + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) +@end lisp + +@vindex gnus-score-decay-scale +@vindex gnus-score-decay-constant +@code{gnus-score-decay-constant} is 3 by default and +@code{gnus-score-decay-scale} is 0.05. This should cause the following: + +@enumerate +@item +Scores between -3 and 3 will be set to 0 when this function is called. + +@item +Scores with magnitudes between 3 and 60 will be shrunk by 3. + +@item +Scores with magnitudes greater than 60 will be shrunk by 5% of the +score. +@end enumerate + +If you don't like this decay function, write your own. It is called +with the score to be decayed as its only parameter, and it should return +the new score, which should be an integer. + +Gnus will try to decay scores once a day. If you haven't run Gnus for +four days, Gnus will decay the scores four times, for instance. + @node Various @chapter Various @@ -10060,6 +12099,9 @@ * Daemons:: Gnus can do things behind your back. * NoCeM:: How to avoid spam and other fatty foods. * Picons:: How to display pictures of what your reading. +* Undo:: Some actions can be undone. +* Moderation:: What to do if you're a moderator. +* XEmacs Enhancements:: There are more pictures and stuff under XEmacs. * Various Various:: Things that are really various. @end menu @@ -10095,6 +12137,11 @@ Quite simple, really, but it needs to be made clear so that surprises are avoided. +Commands that react to the process mark will push the current list of +process marked articles onto a stack and will then clear all process +marked articles. You can restore the previous configuration with the +@kbd{M P y} command (@pxref{Setting Process Marks}). + @vindex gnus-summary-goto-unread One thing that seems to shock & horrify lots of people is that, for instance, @kbd{3 d} does exactly the same as @kbd{d} @kbd{d} @kbd{d}. @@ -10152,19 +12199,142 @@ %(%g%)\n}. We see that it is indeed extremely ugly, and that there are lots of percentages everywhere. +@menu +* Formatting Basics:: A formatting variable is basically a format string. +* Advanced Formatting:: Modifying output in various ways. +* User-Defined Specs:: Having Gnus call your own functions. +* Formatting Fonts:: Making the formatting look colorful and nice. +@end menu + +Currently Gnus uses the following formatting variables: +@code{gnus-group-line-format}, @code{gnus-summary-line-format}, +@code{gnus-server-line-format}, @code{gnus-topic-line-format}, +@code{gnus-group-mode-line-format}, +@code{gnus-summary-mode-line-format}, +@code{gnus-article-mode-line-format}, +@code{gnus-server-mode-line-format}, and +@code{gnus-summary-pick-line-format}. + +All these format variables can also be arbitrary elisp forms. In that +case, they will be @code{eval}ed to insert the required lines. + +@kindex M-x gnus-update-format +@findex gnus-update-format +Gnus includes a command to help you while creating your own format +specs. @kbd{M-x gnus-update-format} will @code{eval} the current form, +update the spec in question and pop you to a buffer where you can +examine the resulting lisp code to be run to generate the line. + + + +@node Formatting Basics +@subsection Formatting Basics + Each @samp{%} element will be replaced by some string or other when the buffer in question is generated. @samp{%5y} means ``insert the @samp{y} -spec, and pad with spaces to get a 5-character field''. Just like a -normal format spec, almost. - -You can also say @samp{%6,4y}, which means that the field will never be -more than 4 characters wide and never less than 6 characters wide. - -There are also specs for highlighting, and these are shared by all the -format variables. Text inside the @samp{%(} and @samp{%)} specifiers -will get the special @code{mouse-face} property set, which means that it -will be highlighted (with @code{gnus-mouse-face}) when you put the mouse -pointer over it. +spec, and pad with spaces to get a 5-character field''. + +As with normal C and Emacs Lisp formatting strings, the numerical +modifier between the @samp{%} and the formatting type character will +@dfn{pad} the output so that it is always at least that long. +@samp{%5y} will make the field always (at least) five characters wide by +padding with spaces to the left. If you say @samp{%-5y}, it will pad to +the right instead. + +You may also wish to limit the length of the field to protect against +particularly wide values. For that you can say @samp{%4,6y}, which +means that the field will never be more than 6 characters wide and never +less than 4 characters wide. + + +@node Advanced Formatting +@subsection Advanced Formatting + +It is frequently useful to post-process the fields in some way. +Padding, limiting, cutting off parts and suppressing certain values can +be achieved by using @dfn{tilde modifiers}. A typical tilde spec might +look like @samp{%~(cut 3)~(ignore "0")y}. + +These are the legal modifiers: + +@table @code +@item pad +@itemx pad-left +Pad the field to the left with spaces until it reaches the required +length. + +@item pad-right +Pad the field to the right with spaces until it reaches the required +length. + +@item max +@itemx max-left +Cut off characters from the left until it reaches the specified length. + +@item max-right +Cut off characters from the right until it reaches the specified +length. + +@item cut +@itemx cut-left +Cut off the specified number of characters from the left. + +@item cut-right +Cut off the specified number of characters from the right. + +@item ignore +Return an empty string if the field is equal to the specified value. + +@item form +Use the specified form as the field value when the @samp{@@} spec is +used. +@end table + +Let's take an example. The @samp{%o} spec in the summary mode lines +will return a date in compact ISO8601 format---@samp{19960809T230410}. +This is quite a mouthful, so we want to shave off the century number and +the time, leaving us with a six-character date. That would be +@samp{%~(cut-left 2)~(max-right 6)~(pad 6)o}. (Cutting is done before +maxing, and we need the padding to ensure that the date is never less +than 6 characters to make it look nice in columns.) + +Ignoring is done first; then cutting; then maxing; and then as the very +last operation, padding. + +If you use lots of these advanced thingies, you'll find that Gnus gets +quite slow. This can be helped enormously by running @kbd{M-x +gnus-compile} when you are satisfied with the look of your lines. +@xref{Compilation}. + + +@node User-Defined Specs +@subsection User-Defined Specs + +All the specs allow for inserting user defined specifiers---@samp{u}. +The next character in the format string should be a letter. Gnus +will call the function @code{gnus-user-format-function-}@samp{X}, where +@samp{X} is the letter following @samp{%u}. The function will be passed +a single parameter---what the parameter means depends on what buffer +it's being called from. The function should return a string, which will +be inserted into the buffer just like information from any other +specifier. This function may also be called with dummy values, so it +should protect against that. + +You can also use tilde modifiers (@pxref{Advanced Formatting} to achieve +much the same without defining new functions. Here's an example: +@samp{%~(form (count-lines (point-min) (point)))@@}. The form +given here will be evaluated to yield the current line number, and then +inserted. + + +@node Formatting Fonts +@subsection Formatting Fonts + +There are specs for highlighting, and these are shared by all the format +variables. Text inside the @samp{%(} and @samp{%)} specifiers will get +the special @code{mouse-face} property set, which means that it will be +highlighted (with @code{gnus-mouse-face}) when you put the mouse pointer +over it. Text inside the @samp{%[} and @samp{%]} specifiers will have their normal faces set using @code{gnus-face-0}, which is @code{bold} by @@ -10196,27 +12366,9 @@ I'm sure you'll be able to use this scheme to create totally unreadable and extremely vulgar displays. Have fun! -Currently Gnus uses the following formatting variables: -@code{gnus-group-line-format}, @code{gnus-summary-line-format}, -@code{gnus-server-line-format}, @code{gnus-topic-line-format}, -@code{gnus-group-mode-line-format}, -@code{gnus-summary-mode-line-format}, -@code{gnus-article-mode-line-format}, -@code{gnus-server-mode-line-format}. - Note that the @samp{%(} specs (and friends) do not make any sense on the mode-line variables. -All these format variables can also be arbitrary elisp forms. In that -case, they will be @code{eval}ed to insert the required lines. - -@kindex M-x gnus-update-format -@findex gnus-update-format -Gnus includes a command to help you while creating your own format -specs. @kbd{M-x gnus-update-format} will @code{eval} the current form, -update the spec in question and pop you to a buffer where you can -examine the resulting lisp code to be run to generate the line. - @node Windows Configuration @section Windows Configuration @@ -10245,7 +12397,7 @@ configuration function will use @code{group} as the key. A full list of possible names is listed below. -The @dfn{value} (i. e., the @dfn{split}) says how much space each buffer +The @dfn{value} (i.e., the @dfn{split}) says how much space each buffer should occupy. To take the @code{article} split as an example - @lisp @@ -10406,16 +12558,16 @@ Note that the @code{message} key is used for both @code{gnus-group-mail} and @code{gnus-summary-mail-other-window}. If -it is desireable to distinguish between the two, something like this +it is desirable to distinguish between the two, something like this might be used: @lisp (message (horizontal 1.0 - (vertical 1.0 (message 1.0 point)) - (vertical 0.24 - (if (buffer-live-p gnus-summary-buffer) - '(summary 0.5)) - (group 1.0))))) + (vertical 1.0 (message 1.0 point)) + (vertical 0.24 + (if (buffer-live-p gnus-summary-buffer) + '(summary 0.5)) + (group 1.0))))) @end lisp @findex gnus-add-configuration @@ -10433,12 +12585,18 @@ @end lisp You'd typically stick these @code{gnus-add-configuration} calls in your -@file{.gnus} file or in some startup hook---they should be run after +@file{.gnus.el} file or in some startup hook---they should be run after Gnus has been loaded. - -@node Compilation -@section Compilation +@vindex gnus-always-force-window-configuration +If all windows mentioned in the configuration are already visible, Gnus +won't change the window configuration. If you always want to force the +``right'' window configuration, you can set +@code{gnus-always-force-window-configuration} to non-@code{nil}. + + +@node Compilation +@section Compilation @cindex compilation @cindex byte-compilation @@ -10455,7 +12613,10 @@ To help with this, you can run @kbd{M-x gnus-compile} after you've fiddled around with the variables and feel that you're (kind of) satisfied. This will result in the new specs being byte-compiled, and -you'll get top speed again. +you'll get top speed again. Gnus will save these compiled specs in the +@file{.newsrc.eld} file. (User-defined functions aren't compiled by +this function, though---you should compile them yourself by sticking +them into the @code{.gnus.el} file and byte-compiling that file.) @node Mode Lines @@ -10476,11 +12637,11 @@ @vindex gnus-mode-non-string-length By default, Gnus displays information on the current article in the mode lines of the summary and article buffers. The information Gnus wishes -to display (eg. the subject of the article) is often longer than the +to display (e.g. the subject of the article) is often longer than the mode lines, and therefore have to be cut off at some point. The @code{gnus-mode-non-string-length} variable says how long the other elements on the line is (i.e., the non-info part). If you put -additional elements on the mode line (eg. a clock), you should modify +additional elements on the mode line (e.g. a clock), you should modify this variable: @c Hook written by Francesco Potorti` @@ -10495,6 +12656,10 @@ If this variable is @code{nil} (which is the default), the mode line strings won't be chopped off, and they won't be padded either. +Note that the default is unlikely to be desirable, as even the +percentage complete in the buffer may be crowded off the mode line; +the user should configure this variable appropriately for their +configuration. @node Highlighting and Menus @@ -10561,21 +12726,6 @@ This is the face (i.e., font) used for mouse highlighting in Gnus. No mouse highlights will be done if @code{gnus-visual} is @code{nil}. -@item gnus-display-type -@vindex gnus-display-type -This variable is symbol indicating the display type Emacs is running -under. The symbol should be one of @code{color}, @code{grayscale} or -@code{mono}. If Gnus guesses this display attribute wrongly, either set -this variable in your @file{~/.emacs} or set the resource -@code{Emacs.displayType} in your @file{~/.Xdefaults}. - -@item gnus-background-mode -@vindex gnus-background-mode -This is a symbol indicating the Emacs background brightness. The symbol -should be one of @code{light} or @code{dark}. If Gnus guesses this -frame attribute wrongly, either set this variable in your @file{~/.emacs} or -set the resource @code{Emacs.backgroundMode} in your @file{~/.Xdefaults}. -`gnus-display-type'. @end table There are hooks associated with the creation of all the different menus: @@ -10717,7 +12867,7 @@ @vindex gnus-demon-timestep (When I say ``minute'' here, I really mean @code{gnus-demon-timestep} -seconds. This is @code{60} by default. If you change that variable, +seconds. This is 60 by default. If you change that variable, all the timings in the handlers will be affected.) @vindex gnus-use-demon @@ -10734,11 +12884,12 @@ @findex gnus-demon-add-nocem @findex gnus-demon-add-scanmail +@findex gnus-demon-add-rescan @findex gnus-demon-add-disconnection Some ready-made functions to do this has been created: -@code{gnus-demon-add-nocem}, @code{gnus-demon-add-disconnection}, and -@code{gnus-demon-add-scanmail}. Just put those functions in your -@file{.gnus} if you want those abilities. +@code{gnus-demon-add-nocem}, @code{gnus-demon-add-disconnection}, +@code{gnus-demon-add-rescan}, and @code{gnus-demon-add-scanmail}. Just +put those functions in your @file{.gnus} if you want those abilities. @findex gnus-demon-init @findex gnus-demon-cancel @@ -10786,7 +12937,8 @@ @item gnus-nocem-groups @vindex gnus-nocem-groups Gnus will look for NoCeM messages in the groups in this list. The -default is @code{("alt.nocem.misc" "news.admin.net-abuse.announce")}. +default is @code{("news.lists.filters" "news.admin.net-abuse.bulletins" +"alt.nocem.misc" "news.admin.net-abuse.announce")}. @item gnus-nocem-issuers @vindex gnus-nocem-issuers @@ -10810,7 +12962,8 @@ @item jem@@xpat.com; @cindex Jem -Jem---Korean despammer who is getting very busy these days. +John Milburn---despammer located in Korea who is getting very busy these +days. @item red@@redpoll.mrfs.oh.us (Richard E. Depew) Richard E. Depew---lone American despammer. He mostly cancels binary @@ -10820,6 +12973,14 @@ You do not have to heed NoCeM messages from all these people---just the ones you want to listen to. +@item gnus-nocem-verifyer +@vindex gnus-nocem-verifyer +@findex mc-verify +This should be a function for verifying that the NoCeM issuer is who she +says she is. The default is @code{mc-verify}, which is a Mailcrypt +function. If this is too slow and you don't care for verification +(which may be dangerous), you can set this variable to @code{nil}. + @item gnus-nocem-directory @vindex gnus-nocem-directory This is where Gnus will store its NoCeM cache files. The default is @@ -10853,8 +13014,7 @@ @node Picon Basics @subsection Picon Basics -What are Picons? To quote directly from the Picons Web site -(@samp{http://www.cs.indiana.edu/picons/ftp/index.html}): +What are Picons? To quote directly from the Picons Web site: @quotation @dfn{Picons} is short for ``personal icons''. They're small, @@ -10866,9 +13026,9 @@ @code{GIF} formats. @end quotation -Please see the above mentioned web site for instructions on obtaining -and installing the picons databases, or the following ftp site: -@samp{http://www.cs.indiana.edu/picons/ftp/index.html}. +For instructions on obtaining and installing the picons databases, point +your Web browser at +@file{http://www.cs.indiana.edu/picons/ftp/index.html}. @vindex gnus-picons-database Gnus expects picons to be installed into a location pointed to by @@ -10920,9 +13080,9 @@ Where the picon images should be displayed. It is @code{picons} by default (which by default maps to the buffer @samp{*Picons*}). Other valid places could be @code{article}, @code{summary}, or -@samp{"*scratch*"} for all I care. Just make sure that you've made the +@samp{*scratch*} for all I care. Just make sure that you've made the buffer visible using the standard Gnus window configuration -routines---@xref{Windows Configuration}. +routines---@pxref{Windows Configuration}. @end table @@ -10986,7 +13146,7 @@ @item gnus-picons-user-directories @vindex gnus-picons-user-directories List of subdirectories to search in @code{gnus-picons-database} for user -faces. Defaults to @code{("local" "users" "usenix" "misc/MISC")}. +faces. @code{("local" "users" "usenix" "misc/MISC")} is the default. @item gnus-picons-domain-directories @vindex gnus-picons-domain-directories @@ -11014,6 +13174,140 @@ @end table +@node Undo +@section Undo +@cindex undo + +It is very useful to be able to undo actions one has done. In normal +Emacs buffers, it's easy enough---you just push the @code{undo} button. +In Gnus buffers, however, it isn't that simple. + +The things Gnus displays in its buffer is of no value whatsoever to +Gnus---it's all just data that is designed to look nice to the user. +Killing a group in the group buffer with @kbd{C-k} makes the line +disappear, but that's just a side-effect of the real action---the +removal of the group in question from the internal Gnus structures. +Undoing something like that can't be done by the normal Emacs +@code{undo} function. + +Gnus tries to remedy this somewhat by keeping track of what the user +does and coming up with actions that would reverse the actions the user +takes. When the user then presses the @code{undo} key, Gnus will run +the code to reverse the previous action, or the previous actions. +However, not all actions are easily reversible, so Gnus currently offers +a few key functions to be undoable. These include killing groups, +yanking groups, and changing the list of read articles of groups. +That's it, really. More functions may be added in the future, but each +added function means an increase in data to be stored, so Gnus will +never be totally undoable. + +@findex gnus-undo-mode +@vindex gnus-use-undo +@findex gnus-undo +The undoability is provided by the @code{gnus-undo-mode} minor mode. It +is used if @code{gnus-use-undo} is non-@code{nil}, which is the +default. The @kbd{M-C-_} key performs the @code{gnus-undo} command +command, which should feel kinda like the normal Emacs @code{undo} +command. + + +@node Moderation +@section Moderation +@cindex moderation + +If you are a moderator, you can use the @file{gnus-mdrtn.el} package. +It is not included in the standard Gnus package. Write a mail to +@samp{larsi@@ifi.uio.no} and state what group you moderate, and you'll +get a copy. + +The moderation package is implemented as a minor mode for summary +buffers. Put + +@lisp +(add-hook 'gnus-summary-mode-hook 'gnus-moderate) +@end lisp + +in your @file{.gnus.el} file. + +If you are the moderation of @samp{rec.zoofle}, this is how it's +supposed to work: + +@enumerate +@item +You split your incoming mail by matching on +@samp{Newsgroups:.*rec.zoofle}, which will put all the to-be-posted +articles in some mail group---for instance, @samp{nnml:rec.zoofle}. + +@item +You enter that group once in a while and post articles using the @kbd{e} +(edit-and-post) or @kbd{s} (just send unedited) commands. + +@item +If, while reading the @samp{rec.zoofle} newsgroup, you happen upon some +articles that weren't approved by you, you can cancel them with the +@kbd{c} command. +@end enumerate + +To use moderation mode in these two groups, say: + +@lisp +(setq gnus-moderated-list + "^nnml:rec.zoofle$\\|^rec.zoofle$") +@end lisp + + +@node XEmacs Enhancements +@section XEmacs Enhancements +@cindex XEmacs + +XEmacs is able to display pictures and stuff, so Gnus has taken +advantage of that. Relevant variables include: + +@table @code +@item gnus-xmas-glyph-directory +@vindex gnus-xmas-glyph-directory +This is where Gnus will look for pictures. Gnus will normally +auto-detect this directory, but you may set it manually if you have an +unusual directory structure. + +@item gnus-xmas-logo-color-alist +@vindex gnus-xmas-logo-color-alist +This is an alist where the key is a type symbol and the values are the +foreground and background color of the splash page glyph. + +@item gnus-xmas-logo-color-style +@vindex gnus-xmas-logo-color-style +This is the key used to look up the color in the alist described above. +Legal values include @code{flame}, @code{pine}, @code{moss}, +@code{irish}, @code{sky}, @code{tin}, @code{velvet}, @code{grape}, +@code{labia}, @code{berry}, @code{neutral}, and @code{september}. + +@item gnus-use-toolbar +@vindex gnus-use-toolbar +If @code{nil}, don't display toolbars. If non-@code{nil}, it should be +one of @code{default-toolbar}, @code{top-toolbar}, @code{bottom-toolbar}, +@code{right-toolbar}, or @code{left-toolbar}. + +@item gnus-group-toolbar +@vindex gnus-group-toolbar +The toolbar in the group buffer. + +@item gnus-summary-toolbar +@vindex gnus-summary-toolbar +The toolbar in the summary buffer. + +@item gnus-summary-mail-toolbar +@vindex gnus-summary-mail-toolbar +The toolbar in the summary buffer of mail groups. + +@item gnus-xmas-modeline-glyph +@vindex gnus-xmas-modeline-glyph +A glyph displayed in all Gnus mode lines. It is a tiny gnu head by +default. + +@end table + + @node Various Various @section Various Various @cindex mode lines @@ -11021,6 +13315,21 @@ @table @code +@item gnus-directory +@vindex gnus-directory +All Gnus directories will be initialized from this variable, which +defaults to the @samp{SAVEDIR} environment variable, or @file{~/News/} +if that variable isn't set. + +@item gnus-default-directory +@vindex gnus-default-directory +Not related to the above variable at all---this variable says what the +default directory of all Gnus buffers should be. If you issue commands +like @kbd{C-x C-f}, the prompt you'll get starts in the current buffer's +default directory. If this variable is @code{nil} (which is the +default), the default directory will be the default directory of the +buffer you were in when you started Gnus. + @item gnus-verbose @vindex gnus-verbose This variable is an integer between zero and ten. The higher the value, @@ -11037,7 +13346,7 @@ @item nnheader-max-head-length @vindex nnheader-max-head-length When the backends read straight heads of articles, they all try to read -as little as possible. This variable (default @code{4096}) specifies +as little as possible. This variable (default 4096) specifies the absolute max length the backends will try to read before giving up on finding a separator line between the head and the body. If this variable is @code{nil}, there is no upper read bound. If it is @@ -11045,6 +13354,11 @@ but read the entire articles. This makes sense with some versions of @code{ange-ftp}. +@item nnheader-head-chop-length +@vindex nnheader-head-chop-length +This variable says how big a piece of each article to read when doing +the operation described above. + @item nnheader-file-name-translation-alist @vindex nnheader-file-name-translation-alist @cindex file names @@ -11094,6 +13408,7 @@ @quotation @strong{Te Deum} + @sp 1 Not because of victories @* I sing,@* @@ -11101,6 +13416,7 @@ but for the common sunshine,@* the breeze,@* the largess of the spring. + @sp 1 Not for victory@* but for the day's work done@* @@ -11138,7 +13454,7 @@ as The Site That Destroys Newsrcs And Drives People Mad. During the first extended alpha period of development, the new Gnus was -called ``(ding) Gnus''. @dfn{(ding)}, is, of course, short for +called ``(ding) Gnus''. @dfn{(ding)} is, of course, short for @dfn{ding is not Gnus}, which is a total and utter lie, but who cares? (Besides, the ``Gnus'' in this abbreviation should probably be pronounced ``news'' as @sc{Umeda} intended, which makes it a more @@ -11150,10 +13466,21 @@ ``@sc{gnus}''. New vs. old. The first ``proper'' release of Gnus 5 was done in November 1995 when it -was included in the Emacs 19.30 distribution. - -In May 1996 the next Gnus generation (aka. ``September Gnus'') was -released under the name ``Gnus 5.2''. +was included in the Emacs 19.30 distribution (132 (ding) Gnus releases +plus 15 Gnus 5.0 releases). + +In May 1996 the next Gnus generation (aka. ``September Gnus'' (after 99 +releases)) was released under the name ``Gnus 5.2'' (40 releases). + +On July 28th 1996 work on Red Gnus was begun, and it was released on +January 25th 1997 (after 84 releases) as ``Gnus 5.4''. + +If you happen upon a version of Gnus that has a name that is prefixed -- +``(ding) Gnus'', ``September Gnus'', ``Red Gnus'', ``Quassia Gnus'' -- +don't panic. Don't let it know that you're frightened. Back away. +Slowly. Whatever you do, don't run. Walk away, calmly, until you're +out of its reach. Find a proper released version of Gnus and snuggle up +to that instead. @menu * Why?:: What's the point of Gnus? @@ -11297,14 +13624,6 @@ coming from @code{tin} and @code{Netscape} I know not to use either of those for posting articles. I would not have known that if it wasn't for the @code{X-Newsreader} header. - -@item References -Gnus does line breaking on this header. I infer from RFC1036 that being -conservative in what you output is not creating 5000-character lines, so -it seems like a good idea to me. However, this standard-to-be says that -whitespace in the @code{References} header is to be preserved, so... It -doesn't matter one way or the other to Gnus, so if somebody tells me -what The Way is, I'll change it. Or not. @end table @end table @@ -11326,43 +13645,23 @@ @itemize @bullet @item -Emacs 19.30 and up. - -@item -XEmacs 19.13 and up. - -@item -Mule versions based on Emacs 19.30 and up. +Emacs 19.32 and up. + +@item +XEmacs 19.14 and up. + +@item +Mule versions based on Emacs 19.32 and up. @end itemize Gnus will absolutely not work on any Emacsen older than that. Not reliably, at least. -There are some vague differences between Gnus on the various platforms: - -@itemize @bullet - -@item -The mouse-face on Gnus lines under Emacs and Mule is delimited to -certain parts of the lines while they cover the entire line under -XEmacs. - -@item -The same with current-article marking---XEmacs puts an underline under -the entire summary line while Emacs and Mule are nicer and kinder. - -@item -XEmacs features more graphics---a logo and a toolbar. - -@item -Citation highlighting us better under Emacs and Mule than under XEmacs. - -@item -Emacs 19.26-19.28 have tangible hidden headers, which can be a bit -confusing. - -@end itemize +There are some vague differences between Gnus on the various +platforms---XEmacs features more graphics (a logo and a toolbar)---but +other than that, things should look pretty much the same under all +Emacsen. @node Contributors @@ -11385,70 +13684,209 @@ @itemize @bullet -@item Masanobu @sc{Umeda} -The writer of the original @sc{gnus}. - -@item Per Abrahamsen -Custom, scoring, highlighting and @sc{soup} code (as well as numerous -other things). - -@item Luis Fernandes -Design and graphics. - -@item Wes Hardaker -@file{gnus-picon.el} and the manual section on @dfn{picons} -(@pxref{Picons}). - -@item Brad Miller -@file{gnus-gl.el} and the GroupLens manual section (@pxref{GroupLens}). - -@item Sudish Joseph -Innumerable bug fixes. - -@item Ilja Weis -@file{gnus-topic.el}. - -@item Steven L. Baur -Lots and lots of bugs detections and fixes. - -@item Vladimir Alexiev -The refcard and reference booklets. - -@item Felix Lee & JWZ -I stole some pieces from the XGnus distribution by Felix Lee and JWZ. - -@item Scott Byer -@file{nnfolder.el} enhancements & rewrite. - -@item Peter Mutsaers -Orphan article scoring code. - -@item Ken Raeburn -POP mail support. - -@item Hallvard B Furuseth -Various bits and pieces, especially dealing with .newsrc files. - -@item Brian Edmonds -@file{gnus-bbdb.el}. - -@item Ricardo Nassif and Mark Borges -Proof-reading. - -@item Kevin Davidson -Came up with the name @dfn{ding}, so blame him. +@item +Masanobu @sc{Umeda}---the writer of the original @sc{gnus}. + +@item +Per Abrahamsen---custom, scoring, highlighting and @sc{soup} code (as +well as numerous other things). + +@item +Luis Fernandes---design and graphics. + +@item +Erik Naggum---help, ideas, support, code and stuff. + +@item +Wes Hardaker---@file{gnus-picon.el} and the manual section on +@dfn{picons} (@pxref{Picons}). + +@item +Brad Miller---@file{gnus-gl.el} and the GroupLens manual section +(@pxref{GroupLens}). + +@item +Sudish Joseph---innumerable bug fixes. + +@item +Ilja Weis---@file{gnus-topic.el}. + +@item +Steven L. Baur---lots and lots and lots of bugs detections and fixes. + +@item +Vladimir Alexiev---the refcard and reference booklets. + +@item +Felix Lee & Jamie Zawinsky---I stole some pieces from the XGnus +distribution by Felix Lee and JWZ. + +@item +Scott Byer---@file{nnfolder.el} enhancements & rewrite. + +@item +Peter Mutsaers---orphan article scoring code. + +@item +Ken Raeburn---POP mail support. + +@item +Hallvard B Furuseth---various bits and pieces, especially dealing with +.newsrc files. + +@item +Brian Edmonds---@file{gnus-bbdb.el}. + +@item +David Moore---rewrite of @file{nnvirtual.el} and many other things. + +@item +Ricardo Nassif, Mark Borges, and Jost Krieger---proof-reading. + +@item +Kevin Davidson---came up with the name @dfn{ding}, so blame him. + +@item +François Pinard---many, many interesting and thorough bug reports. @end itemize -Peter Arius, Stainless Steel Rat, Ulrik Dickow, Jack Vinson, Daniel -Quinlan, Frank D. Cringle, Geoffrey T. Dairiki, Fabrice Popineau and -Andrew Eskilsson have all contributed code and suggestions. +The following people have contributed many patches and suggestions: + +Christopher Davis, +Andrew Eskilsson, +Kai Grossjohann, +David Kågedal, +Richard Pieri, +Fabrice Popineau, +Daniel Quinlan, +Jason L. Tibbitts, III, +and +Jack Vinson. + +Also thanks to the following for patches and stuff: + +Peter Arius, +Marc Auslander, +Chris Bone, +Mark Borges, +Lance A. Brown, +Kees de Bruin, +Martin Buchholz, +Kevin Buhr, +Alastair Burt, +Joao Cachopo, +Massimo Campostrini, +Michael R. Cook, +Glenn Coombs, +Frank D. Cringle, +Geoffrey T. Dairiki, +Andre Deparade, +Ulrik Dickow, +Dave Disser, +Joev Dubach, +Paul Eggert, +Michael Ernst, +Luc Van Eycken, +Sam Falkner, +Paul Franklin, +David S. Goldberg, +D. Hall, +Magnus Hammerin, +Raja R. Harinath, +Hisashige Kenji, @c Hisashige +Marc Horowitz, +François Felix Ingrand, +Ishikawa Ichiro, @c Ishikawa +Lee Iverson, +Rajappa Iyer, +Randell Jesup, +Fred Johansen, +Greg Klanderman, +Peter Skov Knudsen, +Shuhei Kobayashi, @c Kobayashi +Thor Kristoffersen, +Jens Lautenbacher, +Carsten Leonhardt, +Christian Limpach, +Markus Linnala, +Dave Love, +Tonny Madsen, +Shlomo Mahlab, +Nat Makarevitch, +Timo Metzemakers, +Richard Mlynarik, +Lantz Moore, +Morioka Tomohiko, @c Morioka +Erik Toubro Nielsen, +Hrvoje Niksic, +Andy Norman, +C. R. Oldham, +Alexandre Oliva, +Ken Olstad, +Masaharu Onishi, @c Onishi +Hideki Ono, @c Ono +William Perry, +Stephen Peters, +Ulrich Pfeifer, +John McClary Prevost, +Colin Rafferty, +Bart Robinson, +Jason Rumney, +Loren Schall, +Dan Schmidt, +Ralph Schleicher, +Randal L. Schwartz, +Danny Siu, +Paul D. Smith, +Jeff Sparkes, +Michael Sperber, +Richard Stallman, +Greg Stark, +Paul Stodghill, +Kurt Swanson, +Samuel Tardieu, +Teddy, +Chuck Thompson, +Philippe Troin, +Jan Vroonhof, +Barry A. Warsaw, +Christoph Wedler, +Joe Wells, +and +Katsumi Yamaoka. @c Yamaoka + +For a full overview of what each person has done, the ChangeLogs +included in the Gnus alpha distributions should give ample reading +(550kB and counting). + +Apologies to everybody that I've forgotten, of which there are many, I'm +sure. + +Gee, that's quite a list of people. I guess that must mean that there +actually are people who are using Gnus. Who'd'a thunk it! @node New Features @subsection New Features @cindex new features +@menu +* ding Gnus:: New things in Gnus 5.0/5.1, the first new Gnus. +* September Gnus:: The Thing Formally Known As Gnus 5.3/5.3. +* Red Gnus:: Third time best---Gnus 5.4/5.5. +@end menu + +These lists are, of course, just @emph{short} overviews of the +@emph{most} important new features. No, really. There are tons more. +Yes, we have feeping creaturism in full effect. + + +@node ding Gnus +@subsubsection (ding) Gnus + +New features in Gnus 5.0/5.1: + @itemize @bullet @item @@ -11558,15 +13996,391 @@ You can click on buttons instead of using the keyboard (@pxref{Buttons}). -@item -Gnus can use NoCeM files to weed out spam (@pxref{NoCeM}). +@end itemize + + +@node September Gnus +@subsubsection September Gnus + +New features in Gnus 5.2/5.3: + +@itemize @bullet + +@item +A new message composition mode is used. All old customization variables +for @code{mail-mode}, @code{rnews-reply-mode} and @code{gnus-msg} are +now obsolete. + +@item +Gnus is now able to generate @dfn{sparse} threads---threads where +missing articles are represented by empty nodes (@pxref{Customizing +Threading}). + +@lisp +(setq gnus-build-sparse-threads 'some) +@end lisp + +@item +Outgoing articles are stored on a special archive server +(@pxref{Archived Messages}). + +@item +Partial thread regeneration now happens when articles are +referred. + +@item +Gnus can make use of GroupLens predictions (@pxref{GroupLens}). + +@item +Picons (personal icons) can be displayed under XEmacs (@pxref{Picons}). + +@item +A @code{trn}-line tree buffer can be displayed (@pxref{Tree Display}). + +@lisp +(setq gnus-use-trees t) +@end lisp + +@item +An @code{nn}-like pick-and-read minor mode is available for the summary +buffers (@pxref{Pick and Read}). + +@lisp +(add-hook 'gnus-summary-mode-hook 'gnus-pick-mode) +@end lisp + +@item +In binary groups you can use a special binary minor mode (@pxref{Binary +Groups}). + +@item +Groups can be grouped in a folding topic hierarchy (@pxref{Group +Topics}). + +@lisp +(add-hook 'gnus-group-mode-hook 'gnus-topic-mode) +@end lisp + +@item +Gnus can re-send and bounce mail (@pxref{Summary Mail Commands}). + +@item +Groups can now have a score, and bubbling based on entry frequency +is possible (@pxref{Group Score}). + +@lisp +(add-hook 'gnus-summary-exit-hook 'gnus-summary-bubble-group) +@end lisp + +@item +Groups can be process-marked, and commands can be performed on +groups of groups (@pxref{Marking Groups}). + +@item +Caching is possible in virtual groups. + +@item +@code{nndoc} now understands all kinds of digests, mail boxes, rnews +news batches, ClariNet briefs collections, and just about everything +else (@pxref{Document Groups}). + +@item +Gnus has a new backend (@code{nnsoup}) to create/read SOUP packets +(@pxref{SOUP}). + +@item +The Gnus cache is much faster. + +@item +Groups can be sorted according to many criteria (@pxref{Sorting +Groups}). + +@item +New group parameters have been introduced to set list-address and +expiry times (@pxref{Group Parameters}). + +@item +All formatting specs allow specifying faces to be used +(@pxref{Formatting Fonts}). + +@item +There are several more commands for setting/removing/acting on process +marked articles on the @kbd{M P} submap (@pxref{Setting Process Marks}). + +@item +The summary buffer can be limited to show parts of the available +articles based on a wide range of criteria. These commands have been +bound to keys on the @kbd{/} submap (@pxref{Limiting}). + +@item +Articles can be made persistent with the @kbd{*} command +(@pxref{Persistent Articles}). + +@item +All functions for hiding article elements are now toggles. + +@item +Article headers can be buttonized (@pxref{Article Washing}). + +@lisp +(add-hook 'gnus-article-display-hook + 'gnus-article-add-buttons-to-head) +@end lisp + +@item +All mail backends support fetching articles by @code{Message-ID}. + +@item +Duplicate mail can now be treated properly (@pxref{Duplicates}). + +@item +All summary mode commands are available directly from the article +buffer (@pxref{Article Keymap}). + +@item +Frames can be part of @code{gnus-buffer-configuration} (@pxref{Windows +Configuration}). + +@item +Mail can be re-scanned by a daemonic process (@pxref{Daemons}). + +@item +Gnus can make use of NoCeM files to weed out spam (@pxref{NoCeM}). + +@lisp +(setq gnus-use-nocem t) +@end lisp + +@item +Groups can be made permanently visible (@pxref{Listing Groups}). + +@lisp +(setq gnus-permanently-visible-groups "^nnml:") +@end lisp + +@item +Many new hooks have been introduced to make customizing easier. + +@item +Gnus respects the @code{Mail-Copies-To} header. + +@item +Threads can be gathered by looking at the @code{References} header +(@pxref{Customizing Threading}). + +@lisp +(setq gnus-summary-thread-gathering-function + 'gnus-gather-threads-by-references) +@end lisp + +@item +Read articles can be stored in a special backlog buffer to avoid +refetching (@pxref{Article Backlog}). + +@lisp +(setq gnus-keep-backlog 50) +@end lisp + +@item +A clean copy of the current article is always stored in a separate +buffer to allow easier treatment. + +@item +Gnus can suggest where to save articles (@pxref{Saving Articles}). + +@item +Gnus doesn't have to do as much prompting when saving (@pxref{Saving +Articles}). + +@lisp +(setq gnus-prompt-before-saving t) +@end lisp + +@item +@code{gnus-uu} can view decoded files asynchronously while fetching +articles (@pxref{Other Decode Variables}). + +@lisp +(setq gnus-uu-grabbed-file-functions 'gnus-uu-grab-view) +@end lisp + +@item +Filling in the article buffer now works properly on cited text +(@pxref{Article Washing}). + +@item +Hiding cited text adds buttons to toggle hiding, and how much +cited text to hide is now customizable (@pxref{Article Hiding}). + +@lisp +(setq gnus-cited-lines-visible 2) +@end lisp + +@item +Boring headers can be hidden (@pxref{Article Hiding}). + +@lisp +(add-hook 'gnus-article-display-hook + 'gnus-article-hide-boring-headers t) +@end lisp + +@item +Default scoring values can now be set from the menu bar. + +@item +Further syntax checking of outgoing articles have been added. @end itemize -This is, of course, just a @emph{short} overview of the @emph{most} -important new features. No, really. There are tons more. Yes, we have -feeping creaturism in full effect, but nothing too gratuitous, I would -hope. + +@node Red Gnus +@subsubsection Red Gnus + +New features in Gnus 5.4/5.5: + +@itemize @bullet + +@item +@file{nntp.el} has been totally rewritten in an asynchronous fashion. + +@item +Article prefetching functionality has been moved up into +Gnus (@pxref{Asynchronous Fetching}). + +@item +Scoring can now be performed with logical operators like @code{and}, +@code{or}, @code{not}, and parent redirection (@pxref{Advanced +Scoring}). + +@item +Article washing status can be displayed in the +article mode line (@pxref{Misc Article}). + +@item +@file{gnus.el} has been split into many smaller files. + +@item +Suppression of duplicate articles based on Message-ID can be done +(@pxref{Duplicate Suppression}). + +@lisp +(setq gnus-suppress-duplicates t) +@end lisp + +@item +New variables for specifying what score and adapt files are to be +considered home score and adapt files (@pxref{Home Score File}). + +@item +@code{nndoc} was rewritten to be easily extendable (@pxref{Document +Server Internals}). + +@item +Groups can inherit group parameters from parent topics (@pxref{Topic +Parameters}). + +@item +Article editing has been revamped and is now actually usable. + +@item +Signatures can be recognized in more intelligent fashions +(@pxref{Article Signature}). + +@item +Summary pick mode has been made to look more @code{nn}-like. Line +numbers are displayed and the @kbd{.} command can be used to pick +articles (@code{Pick and Read}). + +@item +Commands for moving the @file{.newsrc.eld} from one server to +another have been added (@pxref{Changing Servers}). + +@item +A way to specify that ``uninteresting'' fields be suppressed when +generating lines in buffers (@pxref{Advanced Formatting}). + +@item +Several commands in the group buffer can be undone with @kbd{M-C-_} +(@pxref{Undo}). + +@item +Scoring can be done on words using the new score type @code{w} +(@pxref{Score File Format}). + +@item +Adaptive scoring can be done on a Subject word-by-word basis +(@pxref{Adaptive Scoring}). + +@lisp +(setq gnus-use-adaptive-scoring '(word)) +@end lisp + +@item +Scores can be decayed (@pxref{Score Decays}). + +@lisp +(setq gnus-decay-scores t) +@end lisp + +@item +Scoring can be performed using a regexp on the Date header. The Date is +normalized to compact ISO 8601 format first (@pxref{Score File Format}). + +@item +A new command has been added to remove all data on articles from +the native server (@pxref{Changing Servers}). + +@item +A new command for reading collections of documents +(@code{nndoc} with @code{nnvirtual} on top) has been added---@kbd{M-C-d} +(@pxref{Really Various Summary Commands}). + +@item +Process mark sets can be pushed and popped (@pxref{Setting Process +Marks}). + +@item +A new mail-to-news backend makes it possible to post even when the NNTP +server doesn't allow posting (@pxref{Mail-To-News Gateways}). + +@item +A new backend for reading searches from Web search engines +(@dfn{DejaNews}, @dfn{Alta Vista}, @dfn{InReference}) has been added +(@pxref{Web Searches}). + +@item +Groups inside topics can now be sorted using the standard sorting +functions, and each topic can be sorted independently (@pxref{Topic +Sorting}). + +@item +Subsets of the groups can be sorted independently (@code{Sorting +Groups}). + +@item +Cached articles can be pulled into the groups (@pxref{Summary Generation +Commands}). + +@item +Score files are now applied in a more reliable order (@pxref{Score +Variables}). + +@item +Reports on where mail messages end up can be generated (@pxref{Splitting +Mail}). + +@item +More hooks and functions have been added to remove junk from incoming +mail before saving the mail (@pxref{Washing Mail}). + +@item +Emphasized text can be properly fontisized: + +@lisp +(add-hook 'gnus-article-display-hook 'gnus-article-emphasize) +@end lisp + +@end itemize @node Newest Features @@ -11582,20 +14396,78 @@ @item Native @sc{mime} support is something that should be done. @item -A better and simpler method for specifying mail composing methods. -@item -Allow posting through mail-to-news gateways. -@item Really do unbinhexing. @end itemize And much, much, much more. There is more to come than has already been implemented. (But that's always true, isn't it?) -@code{} is where the actual +@file{} is where the actual up-to-the-second todo list is located, so if you're really curious, you could point your Web browser over that-a-way. +@iftex + +@node The Manual +@section The Manual +@cindex colophon +@cindex manual + +This manual was generated from a TeXinfo file and then run through +either @code{texi2dvi} +@iflatex +or my own home-brewed TeXinfo to \LaTeX\ transformer, +and then run through @code{latex} and @code{dvips} +@end iflatex +to get what you hold in your hands now. + +The following conventions have been used: + +@enumerate + +@item +This is a @samp{string} + +@item +This is a @kbd{keystroke} + +@item +This is a @file{file} + +@item +This is a @code{symbol} + +@end enumerate + +So if I were to say ``set @code{flargnoze} to @samp{yes}'', that would +mean: + +@lisp +(setq flargnoze "yes") +@end lisp + +If I say ``set @code{flumphel} to @code{yes}'', that would mean: + +@lisp +(setq flumphel 'yes) +@end lisp + +@samp{yes} and @code{yes} are two @emph{very} different things---don't +ever get them confused. + +@iflatex +@c @head +Of course, everything in this manual is of vital interest, so you should +read it all. Several times. However, if you feel like skimming the +manual, look for that gnu head you should see in the margin over +there---it means that what's being discussed is of more importance than +the rest of the stuff. (On the other hand, if everything is infinitely +important, how can anything be more important than that? Just one more +of the mysteries of this world, I guess.) +@end iflatex + +@end iftex + @node Terminology @section Terminology @@ -11650,7 +14522,7 @@ @item article @cindex article -A nessage that has been posted as news. +A message that has been posted as news. @item mail message @cindex mail message @@ -11713,7 +14585,7 @@ @item bogus groups @cindex bogus groups A group that exists in the @file{.newsrc} file, but isn't known to the -server (i. e., it isn't in the active file), is a @emph{bogus group}. +server (i.e., it isn't in the active file), is a @emph{bogus group}. This means that the group probably doesn't exist (any more). @item server @@ -11728,9 +14600,31 @@ @item virtual server @cindex virtual server A named select method. Since a select methods defines all there is to -know about connecting to a (physical) server, taking the who things as a +know about connecting to a (physical) server, taking the things as a whole is a virtual server. +@item washing +@cindex washing +Taking a buffer and running it through a filter of some sort. The +result will (more often than not) be cleaner and more pleasing than the +original. + +@item ephemeral groups +@cindex ephemeral groups +Most groups store data on what articles you have read. @dfn{Ephemeral} +groups are groups that will have no data stored---when you exit the +group, it'll disappear into the aether. + +@item solid groups +@cindex solid groups +This is the opposite of ephemeral groups. All groups listed in the +group buffer are solid groups. + +@item sparse articles +@cindex sparse articles +These are article placeholders shown in the summary buffer when +@code{gnus-build-sparse-threads} has been switched on. + @end table @@ -11762,7 +14656,7 @@ @item gnus-read-active-file Set this to @code{nil}, which will inhibit Gnus from requesting the entire active file from the server. This file is often v. large. You -also have to set @code{gnus-check-new-news} and +also have to set @code{gnus-check-new-newsgroups} and @code{gnus-check-bogus-newsgroups} to @code{nil} to make sure that Gnus doesn't suddenly decide to fetch the active file anyway. @@ -11888,6 +14782,13 @@ @item Read the help group (@kbd{G h} in the group buffer) for a FAQ and a how-to. + +@item +@vindex max-lisp-eval-depth +Gnus works on many recursive structures, and in some extreme (and very +rare) cases Gnus may recurse down ``too deeply'' and Emacs will beep at +you. If this happens to you, set @code{max-lisp-eval-depth} to 500 or +something like that. @end enumerate If all else fails, report the problem as a bug. @@ -11918,7 +14819,7 @@ If the problem you're seeing is very visual, and you can't quite explain it, copy the Emacs window to a file (with @code{xwd}, for instance), put it somewhere it can be reached, and include the URL of the picture in -the bug report.a +the bug report. If you just need help, you are better off asking on @samp{gnu.emacs.gnus}. I'm not very helpful. @@ -11930,7 +14831,7 @@ @node A Programmers Guide to Gnus -@section A Programmer's Guide to Gnus +@section A Programmer@'s Guide to Gnus It is my hope that other people will figure out smart stuff that Gnus can do, and that other people will write those smart things as well. To @@ -11995,9 +14896,10 @@ All these functions are expected to return data in the buffer @code{nntp-server-buffer} (@samp{ *nntpd*}), which is somewhat unfortunately named, but we'll have to live with it. When I talk about -``resulting data'', I always refer to the data in that buffer. When I -talk about ``return value'', I talk about the function value returned by -the function call. +@dfn{resulting data}, I always refer to the data in that buffer. When I +talk about @dfn{return value}, I talk about the function value returned by +the function call. Functions that fail should return @code{nil} as the +return value. Some backends could be said to be @dfn{server-forming} backends, and some might be said to not be. The latter are backends that generally @@ -12013,7 +14915,10 @@ @menu * Required Backend Functions:: Functions that must be implemented. * Optional Backend Functions:: Functions that need not be implemented. +* Error Messaging:: How to get messages and report errors. * Writing New Backends:: Extending old backends. +* Hooking New Backends Into Gnus:: What has to be done on the Gnus end. +* Mail-like Backends:: Some tips on mail backends. @end menu @@ -12157,25 +15062,21 @@ on successful article retrievement. -@item (nnchoke-open-group GROUP &optional SERVER) - -Make @var{group} the current group. - -There should be no data returned by this function. - - -@item (nnchoke-request-group GROUP &optional SERVER) +@item (nnchoke-request-group GROUP &optional SERVER FAST) Get data on @var{group}. This function also has the side effect of making @var{group} the current group. +If @var{FAST}, don't bother to return useful data, just make @var{group} +the current group. + Here's an example of some result data and a definition of the same: @example 211 56 1000 1059 ifi.discussion @end example -The first number is the status, which should be @code{211}. Next is the +The first number is the status, which should be 211. Next is the total number of articles in the group, the lowest article number, the highest article number, and finally the group name. Note that the total number of articles may be less than one might think while just @@ -12267,9 +15168,8 @@ A Gnus group info (@pxref{Group Info}) is handed to the backend for alterations. This comes in handy if the backend really carries all the information (as is the case with virtual an imap groups). This function -may alter the info in any manner it sees fit, and should return the -(altered) group info. This function may alter the group info -destructively, so no copying is needed before boogeying. +should destructively alter the info to suit its needs, and should return +the (altered) group info. There should be no result data from this function. @@ -12282,7 +15182,8 @@ @code{news} if @var{article} in @var{group} is news, @code{mail} if it is mail and @code{unknown} if the type can't be decided. (The @var{article} parameter is necessary in @code{nnvirtual} groups which -might very well combine mail groups and news groups.) +might very well combine mail groups and news groups.) Both @var{group} +and @var{article} may be @code{nil}. There should be no result data from this function. @@ -12316,19 +15217,6 @@ There should be no result data from this function. -@item (nnchoke-request-asynchronous GROUP &optional SERVER ARTICLES) - -This is a request to fetch articles asynchronously later. -@var{articles} is an alist of @var{(article-number line-number)}. One -would generally expect that if one later fetches article number 4, for -instance, some sort of asynchronous fetching of the articles after 4 -(which might be 5, 6, 7 or 11, 3, 909 depending on the order in that -alist) would be fetched asynchronously, but that is left up to the -backend. Gnus doesn't care. - -There should be no result data from this function. - - @item (nnchoke-request-group-description GROUP &optional SERVER) The result data from this function should be a description of @@ -12441,10 +15329,38 @@ @end table +@node Error Messaging +@subsubsection Error Messaging + +@findex nnheader-report +@findex nnheader-get-report +The backends should use the function @code{nnheader-report} to report +error conditions---they should not raise errors when they aren't able to +perform a request. The first argument to this function is the backend +symbol, and the rest are interpreted as arguments to @code{format} if +there are many of them, or just a string if there is one of them. +This function always returns @code{nil}. + +@lisp +(nnheader-report 'nnchoke "You did something totally bogus") + +(nnheader-report 'nnchoke "Could not request group %s" group) +@end lisp + +Gnus, in turn, will call @code{nnheader-get-report} when it gets a +@code{nil} back from a server, and this function returns the most +recently reported message for the backend in question. This function +takes one argument---the server symbol. + +Internally, these function access @var{backend}@code{-status-string}, so +the @code{nnchoke} backend will have its error message stored in +@code{nnchoke-status-string}. + + @node Writing New Backends @subsubsection Writing New Backends -The various backends share many similarities. @code{nnml} is just like +Many backends are quite similar. @code{nnml} is just like @code{nnspool}, but it allows you to edit the articles on the server. @code{nnmh} is just like @code{nnml}, but it doesn't use an active file, and it doesn't maintain overview databases. @code{nndir} is just like @@ -12582,16 +15498,16 @@ (deffoo nndir-open-server (server &optional defs) (setq nndir-directory - (or (cadr (assq 'nndir-directory defs)) - server)) + (or (cadr (assq 'nndir-directory defs)) + server)) (unless (assq 'nndir-directory defs) (push `(nndir-directory ,server) defs)) (push `(nndir-current-group - ,(file-name-nondirectory (directory-file-name nndir-directory))) - defs) + ,(file-name-nondirectory (directory-file-name nndir-directory))) + defs) (push `(nndir-top-directory - ,(file-name-directory (directory-file-name nndir-directory))) - defs) + ,(file-name-directory (directory-file-name nndir-directory))) + defs) (nnoo-change-server 'nndir server defs)) (nnoo-map-functions nndir @@ -12610,6 +15526,100 @@ @end lisp +@node Hooking New Backends Into Gnus +@subsubsection Hooking New Backends Into Gnus + +@vindex gnus-valid-select-methods +Having Gnus start using your new backend is rather easy---you just +declare it with the @code{gnus-declare-backend} functions. This will +enter the backend into the @code{gnus-valid-select-methods} variable. + +@code{gnus-declare-backend} takes two parameters---the backend name and +an arbitrary number of @dfn{abilities}. + +Here's an example: + +@lisp +(gnus-declare-backend "nnchoke" 'mail 'respool 'address) +@end lisp + +The abilities can be: + +@table @code +@item mail +This is a mailish backend---followups should (probably) go via mail. +@item post +This is a newsish backend---followups should (probably) go via news. +@item post-mail +This backend supports both mail and news. +@item none +This is neither a post or mail backend---it's something completely +different. +@item respool +It supports respooling---or rather, it is able to modify its source +articles and groups. +@item address +The name of the server should be in the virtual server name. This is +true for almost all backends. +@item prompt-address +The user should be prompted for an address when doing commands like +@kbd{B} in the group buffer. This is true for backends like +@code{nntp}, but not @code{nnmbox}, for instance. +@end table + + +@node Mail-like Backends +@subsubsection Mail-like Backends + +One of the things that separate the mail backends from the rest of the +backends is the heavy dependence by the mail backends on common +functions in @file{nnmail.el}. For instance, here's the definition of +@code{nnml-request-scan}: + +@lisp +(deffoo nnml-request-scan (&optional group server) + (setq nnml-article-file-alist nil) + (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) +@end lisp + +It simply just calls @code{nnmail-get-new-mail} will a few parameters, +and @code{nnmail} takes care of all the moving and splitting of the +mail. + +This function takes four parameters. + +@table @var +@item method +This should be a symbol to designate which backend is responsible for +the call. + +@item exit-function +This function should be called after the splitting has been performed. + +@item temp-directory +Where the temporary files should be stored. + +@item group +This optional argument should be a group name if the splitting is to be +performed for one group only. +@end table + +@code{nnmail-get-new-mail} will call @var{backend}@code{-save-mail} to +save each article. @var{backend}@code{-active-number} will be called to +find the article number assigned to this article. + +The function also uses the following variables: +@var{backend}@code{-get-new-mail} (to see whether to get new mail for +this backend); and @var{backend}@code{-group-alist} and +@var{backend}@code{-active-file} to generate the new active file. +@var{backend}@code{-group-alist} should be a group-active alist, like +this: + +@example +(("a-group" (1 . 10)) + ("some-group" (34 . 39))) +@end example + @node Score File Syntax @subsection Score File Syntax @@ -12696,7 +15706,7 @@ just shamelessly @emph{stole} the entire thing, and one would be right. @dfn{Header} is a severely overloaded term. ``Header'' is used in -RFC1036 to talk about lines in the head of an article (eg., +RFC1036 to talk about lines in the head of an article (e.g., @code{From}). It is used by many people as a synonym for ``head''---``the header and the body''. (That should be avoided, in my opinion.) And Gnus uses a format internally that it calls ``header'', @@ -12721,7 +15731,7 @@ The question is simple: If you have a large amount of objects that are identified by numbers (say, articles, to take a @emph{wild} example) -that you want to callify as being ``included'', a normal sequence isn't +that you want to qualify as being ``included'', a normal sequence isn't very useful. (A 200,000 length sequence is a bit long-winded.) The solution is as simple as the question: You just collapse the @@ -12812,10 +15822,17 @@ (auto-expire (to-address "ding@@ifi.uio.no"))) @end example -The first element is the group name as Gnus knows the group; the second -is the group level; the third is the read articles in range format; the -fourth is a list of article marks lists; the fifth is the select method; -and the sixth contains the group parameters. +The first element is the @dfn{group name}---as Gnus knows the group, +anyway. The second element is the @dfn{subscription level}, which +normally is a small integer. The third element is a list of ranges of +read articles. The fourth element is a list of lists of article marks +of various kinds. The fifth element is the select method (or virtual +server, if you like). The sixth element is a list of @dfn{group +parameters}, which is what this section is about. + +Any of the last three elements may be missing if they are not required. +In fact, the vast majority of groups will normally only have the first +three elements, which saves quite a lot of cons cells. Here's a BNF definition of the group info format: diff -r 498bf5da1c90 -r 0d2f883870bc man/lispref/extents.texi --- a/man/lispref/extents.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/lispref/extents.texi Mon Aug 13 09:13:56 2007 +0200 @@ -84,12 +84,12 @@ property controls whether the extent is highlighted when the mouse moves over it. @xref{Extents and Events}. - An extent can optionally have a @dfn{start-glyph} or @dfn{end-glyph} -(but not both at one time) associated with it. A start-glyph or + An extent can optionally have a @dfn{begin-glyph} or @dfn{end-glyph} +(but not both at one time) associated with it. A begin-glyph or end-glyph is a pixmap or string that will be displayed either at the start or end of an extent or in the margin of the line that the start or end of the extent lies in, depending on the extent's layout policy. -Start-glyphs and end-glyphs are used to implement annotations, and you +Begin-glyphs and end-glyphs are used to implement annotations, and you should use the annotation API functions in preference to the lower-level extent functions. For more information, @xref{Annotations}. diff -r 498bf5da1c90 -r 0d2f883870bc man/message.texi --- a/man/message.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/message.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,6 +1,6 @@ \input texinfo @c -*-texinfo-*- -@setfilename ../info/message.info +@setfilename message @settitle Message Manual @synindex fn cp @synindex vr cp @@ -169,7 +169,9 @@ @findex message-wide-reply The @code{message-wide-reply} pops up a message buffer that's a wide -reply to the message in the current buffer. +reply to the message in the current buffer. A @dfn{wide reply} is a +reply that goes out to all people listed in the @code{To}, @code{From} +and @code{Cc} headers. @vindex message-wide-reply-to-function Message uses the normal methods to determine where wide replies are to go, @@ -178,7 +180,7 @@ @code{message-reply-to-function} (@pxref{Reply}). @findex rmail-dont-reply-to-names -Addresses that matches the @code{rmail-dont-reply-to-names} regular +Addresses that match the @code{rmail-dont-reply-to-names} regular expression will be removed from the @code{Cc} header. @@ -220,8 +222,9 @@ @vindex message-ignored-supersedes-headers Headers matching the @code{message-ignored-supersedes-headers} are -removed before popping up the new message buffer. The default is -@samp{^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:}. +removed before popping up the new message buffer. The default is@* +@samp{^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|@* +^Received:\\|^X-From-Line:\\|Return-Path:}. @@ -236,13 +239,13 @@ @table @code @item message-forward-start-separator @vindex message-forward-start-separator -Delimiter inserted before forwarded messages. The default is +Delimiter inserted before forwarded messages. The default is@* @samp{------- Start of forwarded message -------\n}. @vindex message-forward-end-separator @item message-forward-end-separator @vindex message-forward-end-separator -Delimiter inserted after forwarded messages. The default is +Delimiter inserted after forwarded messages. The default is@* @samp{------- End of forwarded message -------\n}. @item message-signature-before-forwarded-message @@ -266,7 +269,7 @@ and resend the message in the current buffer to that address. @vindex message-ignored-resent-headers -Headers the match the @code{message-ignored-resent-headers} regexp will +Headers that match the @code{message-ignored-resent-headers} regexp will be removed before sending the message. The default is @samp{^Return-receipt}. @@ -277,7 +280,9 @@ @findex message-bounce The @code{message-bounce} command will, if the current buffer contains a bounced mail message, pop up a message buffer stripped of the bounce -information. +information. A @dfn{bounced message} is typically a mail you've sent +out that has been returned by some @code{mailer-daemon} as +undeliverable. @vindex message-ignored-bounced-headers Headers that match the @code{message-ignored-bounced-headers} regexp @@ -471,7 +476,7 @@ characters @samp{-- } on a line by themselves. This is to make it easier for the recipient to automatically recognize and process the signature. So don't remove those characters, even though you might feel -that they ruin you beautiful design, like, totally. +that they ruin your beautiful design, like, totally. Also note that no signature should be more than four lines long. Including ASCII graphics is an efficient way to get everybody to believe @@ -492,6 +497,13 @@ rotate the visible portion of the buffer. A numerical prefix says how many places to rotate the text. The default is 13. +@item C-c C-e +@kindex C-c C-e +@findex message-elide-region +Elide the text between point and mark (@code{message-elide-region}). +The text is killed and an ellipsis (@samp{[...]}) will be inserted in +its place. + @item C-c C-t @kindex C-c C-t @findex message-insert-to @@ -622,7 +634,7 @@ @table @code @item message-required-mail-headers @vindex message-required-mail-headers -See @pxref{News Headers} for the syntax of this variable. It is +@xref{News Headers}, for the syntax of this variable. It is @code{(From Date Subject (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer))} by default. @@ -697,9 +709,9 @@ @findex system-name @cindex Sun This required header will be generated by Message. A unique ID will be -created based on date, time, user name and system name. Message will +created based on the date, time, user name and system name. Message will use @code{mail-host-address} as the fully qualified domain name (FQDN) -of the machine if that variable is define. If not, it will use +of the machine if that variable is defined. If not, it will use @code{system-name}, which doesn't report a FQDN on some machines -- notably Suns. @@ -715,7 +727,7 @@ @item In-Reply-To This optional header is filled out using the @code{Date} and @code{From} -header of the article being replied. +header of the article being replied to. @item Expires @cindex Expires @@ -731,11 +743,11 @@ @item Path @cindex path -This extremely optional header should probably not ever be used. +This extremely optional header should probably never be used. However, some @emph{very} old servers require that this header is present. @code{message-user-path} further controls how this -@code{Path} header is to look. If is is @code{nil}, the the server name -as the leaf node. If is is a string, use the string. If it is neither +@code{Path} header is to look. If it is @code{nil}, use the server name +as the leaf node. If it is a string, use the string. If it is neither a string nor @code{nil}, use the user name only. However, it is highly unlikely that you should need to fiddle with this variable at all. @end table @@ -762,7 +774,7 @@ @item message-syntax-checks @vindex message-syntax-checks -If non-@code{nil}, message will attempt to check the legality of the +If non-@code{nil}, Message will attempt to check the legality of the headers, as well as some other stuff, before posting. You can control the granularity of the check by adding or removing elements from this list. Legal elements are: @@ -802,19 +814,22 @@ @item empty-headers Check whether any of the headers are empty. @item existing-newsgroups -Check whether the newsgroups mentioned in the Newsgroups and -Followup-To headers exist. +Check whether the newsgroups mentioned in the @code{Newsgroups} and +@code{Followup-To} headers exist. @item valid-newsgroups -Check whether the @code{Newsgroups} and @code{Followup-To} headers -are valid syntactially. +Check whether the @code{Newsgroups} and @code{Followup-to} headers +are valid syntactically. +@item shorten-followup-to +Check whether to add a @code{Followup-to} header to shorten the number +of groups to post to. @end table All these conditions are checked by default. @item message-ignored-news-headers @vindex message-ignored-news-headers -Regexp of headers to be removed before posting. The default is -@samp{^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:}. +Regexp of headers to be removed before posting. The default is@* +@samp{^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:}. @item message-default-news-headers @vindex message-default-news-headers @@ -879,6 +894,14 @@ @vindex message-send-hook Hook run before sending messages. +@item message-send-mail-hook +@vindex message-send-mail-hook +Hook run before sending mail messages. + +@item message-send-news-hook +@vindex message-send-news-hook +Hook run before sending news messages. + @item message-sent-hook @vindex message-sent-hook Hook run after sending messages. @@ -905,8 +928,11 @@ @item message-courtesy-message @vindex message-courtesy-message When sending combined messages, this string is inserted at the start of -the mailed copy. If this variable is @code{nil}, no such courtesy -message will be added. +the mailed copy. If the string contains the format spec @samp{%s}, the +newsgroups the article has been posted to will be inserted there. If +this variable is @code{nil}, no such courtesy message will be added. +The default value is @samp{"The following message is a courtesy copy of +an article\nthat has been posted to %s as well.\n\n"}. @end table @@ -916,7 +942,7 @@ Message will generate new buffers with unique buffer names when you request a message buffer. When you send the message, the buffer isn't -normally killed off. It's name is changed and a certain number of old +normally killed off. Its name is changed and a certain number of old message buffers are kept alive. @table @code @@ -988,8 +1014,8 @@ This restores the Gnus window configuration when the message buffer is killed, postponed or exited. -An @dfn{action} can be either a normal function; or a list where the -@code{car} is a function and the @code{cdr} is the list of arguments; or +An @dfn{action} can be either: a normal function, or a list where the +@code{car} is a function and the @code{cdr} is the list of arguments, or a form to be @code{eval}ed. @node Index diff -r 498bf5da1c90 -r 0d2f883870bc man/mule/languages.texi --- a/man/mule/languages.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/mule/languages.texi Mon Aug 13 09:13:56 2007 +0200 @@ -4,7 +4,7 @@ @titlepage @sp 6 -@ceter @titlefont{Foreign Languages} +@center @titlefont{Foreign Languages} @sp 4 @center Version 2.1 @sp 5 @@ -618,9 +618,9 @@ read the following text, which contains both ASCII and Thai characters: @example -Mule 0,T$W1M(B editor GNU Emacs 0,T7Uh106Y1!`0>Th1A$GRAJRARC6c0Ki1c0*i1d04i10!Q1:@RIRKERB(B ,Tf(B ,T@RIR(B -0,T;Q1(0(X10:Q1909Ui1(B 0,TAU1(B Mule 0,TCXh19(B 1 0,T+Vh1'c0*i1(B GNU Emacs 0,TCXh19(B 18 ,T`0;g190R9(B ,TaEP(B Mule 0,TCXh19(B 2 0,T+Vh1'c0*i1(B -GNU Emacs 0,TCXh19(B 19 ,T`0;g190R9(B ,T`)>RP(B Mule 0,TCXh19(B 2 ,T`07h1R09Qi1907Uh1(P06Y1!0>Q129R;0CQ1:;0CX1'05h1Md;(B +Mule 0-T¤×1Í editor GNU Emacs 0·Õè10¶Ù1¡à0¾Ôè1Á¤ÇÒÁÊÒÁÒöã0Ëé1ã0ªé1ä0´é10¡Ñ1ºÀÒÉÒËÅÒ æ ÀÒÉÒ-A +0-T»Ñ1¨0¨Ø10ºÑ1¹0¹Õé1 0ÁÕ1 Mule 0ÃØè1¹ 1 0«Öè1§ã0ªé1 GNU Emacs 0ÃØè1¹ 18 à0»ç1¹°Ò¹ áÅÐ Mule 0ÃØè1¹ 2 0«Öè1§ã0ªé1-A +GNU Emacs 0-TÃØè1¹ 19 à0»ç1¹°Ò¹ ੾ÒÐ Mule 0ÃØè1¹ 2 à0·è1Ò0¹Ñé1¹0·Õè1¨Ð0¶Ù1¡0¾Ñ1²¹Ò»0ÃÑ1º»0ÃØ1§0µè1Íä»-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -663,23 +663,23 @@ The Thai keymap in quail-mode looks like this: @example -,TE(B# /,Tq(B _,Tr(B ,T@s(B ,T6t(B ,TXY(B ,TV0Qi1(B ,T$u(B ,T5v(B ,T(w(B ,T"x(B ,T*y(B ,T_o(B ,T#%(B - ,Tfp(B ,Td(B\" ,TS.(B ,T>1(B ,TP8(B ,TQm(B ,TUj(B ,TC3(B ,T9O(B ,TB-(B ,T:0(B ,TE(B, - ,T?D(B ,TK&(B ,T!/(B ,T4b(B ,T`,(B ,Tig(B ,Thk(B ,TRI(B ,TJH(B ,TG+(B ,T'F(B - ,T<(B( ,T;(B) ,Ta)(B ,TMN(B ,TTZ(B ,TWl(B 0,T7n1(B ,TA2(B ,TcL(B ,T=(B? +-TÅ# /ñ _ò Àó ¶ô ØÙ Ö0Ñé1 ¤õ µö ¨÷ ¢ø ªù ßï £¥-A + -Tæð ä\" Ó® ¾± и Ñí Õê ó ¹Ï ­ º° Å,-A + -T¿Ä ˦ ¡¯ ´â ଠéç èë ÒÉ ÊÈ Ç« §Æ-A + -T¼( ») á© ÍÎ ÔÚ ×ì 0·î1 Á² ãÌ ½?-A @end example The difference from the ordinal Thai keyboards are: @itemize @bullet @item -@samp{,T_(B} and @samp{,To(B} are assigned to @key{\} and @key{|} +@samp{-Tß} and @samp{ï} are assigned to @key{\} and @key{|}-A @item -@samp{,T#(B} and @samp{,T%(B} are assigned to @key{`} and @key{~} +@samp{-T£} and @samp{¥} are assigned to @key{`} and @key{~}-A @item -We don't know where to assign characters @samp{,Tz(B} and @samp{,T{(B} +We don't know where to assign characters @samp{-Tú} and @samp{û}-A @end itemize To exit quail-mode, hit @kbd{C-]} once again. @@ -737,14 +737,14 @@ the following text, which contains both ASCII and Vietnamese characters: @example -Mule l,1`(B m,15(Bt s,1q(B gia c,1t(Bng v,1+(B ,1p(Ba ng,1t(Bn ng,1f(B cho GNU Emacs [MULtilingual -Enhancement to GNU Emacs]. Kh,1t(Bng nh,1f(Bng n,1s(B c,1s(B th,1,(B x,1X(B l,1}(B ch,1f(B ASCII (7 -bit) v,1`(B ISO Latin-1 (8 bit) m,1`(B c,1r(Bn c,1s(B th,1,(B x,1X(B l,1}(B Nh,1'(Bt ng,1f(B, Hoa ng,1f(B, H,1`(Bn -ng,1f(B (16 bit) m,1c(B h,1s(Ba theo ti,1j(Bu chu,1&(Bn ISO2022 v,1`(B c,1a(Bc d,18(B b,1d(Bn (th,1m(B d,1x(B nh,1_(B -EUC, Compound Text). ,2p,1/(Bi v,1>(Bi Hoa ng,1f(B, Mule c,1s(B th,1,(B ph,1x(Bc v,1x(B cho c,1d(B GB l,1g(Bn -Big5. Ngo,1`(Bi ra, hi,1.(Bn nay ch,1z(Bng t,1t(Bi c,1{(Bng ph,1x(Bc v,1x(B cho ch,1f(B Th,1a(Bi d,1q(Ba tr,1j(Bn -TIS620 m,1#(Bc d,1%(Bu ti,1j(Bu chu,1&(Bn n,1`(By kh,1t(Bng tu,1b(Bn theo ISO nh,1_(Bng r,1$(Bt ph,11(B th,1t(Bng ,17(B -Th,1a(Bi Lan. +Mule l-1à mµt sñ gia công v« ða ngôn ngæ cho GNU Emacs [MULtilingual-A +Enhancement to GNU Emacs]. Kh-1ông nhæng nó có th¬ xØ lý chæ ASCII (7-A +bit) v-1à ISO Latin-1 (8 bit) mà còn có th¬ xØ lý Nh§t ngæ, Hoa ngæ, Hàn-A +ng-1æ (16 bit) mã hóa theo tiêu chu¦n ISO2022 và các d¸ bän (thí dø nhß-A +EUC, Compound Text). -2ð-1¯i v¾i Hoa ngæ, Mule có th¬ phøc vø cho cä GB lçn-A +Big5. Ngo-1ài ra, hi®n nay chúng tôi cûng phøc vø cho chæ Thái dña trên-A +TIS620 m-1£c d¥u tiêu chu¦n này không tuân theo ISO nhßng r¤t ph± thông ·-A +Th-1ái Lan.-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -804,21 +804,21 @@ @example effect | postfix | examples ------------+---------+---------- - breve | ( | a( -> ,1e(B - circumflex | ^ | a^ -> ,1b(B - horn | + | o+ -> ,1=(B + breve | ( | a( -> -1å-A + circumflex | ^ | a^ -> -1â-A + horn | + | o+ -> -1½-A ------------+---------+---------- - acute | ' | a' -> ,1a(B - grave | ` | a` -> ,1`(B - hook above | ? | a? -> ,1d(B - tilde | ~ | a~ -> ,1c(B - dot below | . | a. -> ,1U(B + acute | ' | a' -> -1á-A + grave | ` | a` -> -1à-A + hook above | ? | a? -> -1ä-A + tilde | ~ | a~ -> -1ã-A + dot below | . | a. -> -1Õ-A ------------+---------+---------- - d bar | dd | dd -> ,1p(B + d bar | dd | dd -> -1ð-A ------------+---------+---------- no compose | \ | a\. -> a. ------------+---------+---------- - combination| (~ | a(~ -> ,1G(B + combination| (~ | a(~ -> -1Ç-A @end example To exit quail-mode, hit @kbd{C-]} once again. @@ -875,8 +875,8 @@ contains many accented characters: @example -,A+(BTout Fran,Ag(Bais de bon go,A{(Bt, m,Aj(Bme r,Ai(Bsident de Capharna,A|(Bm, doit payer la -d,An(Bme ,A`(B No,Ak(Bl ou ,A`(B P,Ab(Bques, en esp,Ah(Bces, en gn,At(Ble ou en ma,Ao(Bs.,A;(B +«Tout Français de bon goût, même résident de Capharnaüm, doit payer la +dîme à Noël ou à Pâques, en espèces, en gnôle ou en maïs.» @end example Bear in mind that all fonts used in Mule must be of fixed width. For @@ -924,7 +924,7 @@ The Quail packages are divided into two groups. The first one is for naive users. Most of the accented letters can be input by composing two -characters. For example, you will get an @samp{,Ai(B} (@samp{e} with acute +characters. For example, you will get an @samp{é} (@samp{e} with acute accent) by typing an @samp{e} followed by a @samp{'} (single quote). @example @@ -995,10 +995,10 @@ acute accent both in upper case and in lower case: @example -ISO 8859-2 (Latin-2): ,BA(B ,Ba(B ,BI(B ,Bi(B ,BM(B ,Bm(B ,BZ(B ,Bz(B -ISO 8859-3 (Latin-3): ,CA(B ,Ca(B ,CI(B ,Ci(B ,CM(B ,Cm(B ,CZ(B ,Cz(B -ISO 8859-4 (Latin-4): ,DA(B ,Da(B ,DI(B ,Di(B ,DM(B ,Dm(B ,DZ(B ,Dz(B -ISO 8859-9 (Latin-5): ,MA(B ,Ma(B ,MI(B ,Mi(B ,MM(B ,Mm(B ,MZ(B ,Mz(B +ISO 8859-2 (Latin-2): -BÁ á É é Í í Ú ú-A +ISO 8859-3 (Latin-3): -CÁ á É é Í í Ú ú-A +ISO 8859-4 (Latin-4): -DÁ á É é Í í Ú ú-A +ISO 8859-9 (Latin-5): -MÁ á É é Í í Ú ú-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -1105,10 +1105,10 @@ to read the following Ukrainian folk song: @example -,L2WoR(B ,LQX(B ,Lo(B ,LQP]Tc`c(B -,LBP(B ,LY(B ,LWPS`PR(B, ,Li^(B ,LW]PR(B. -,LGU`UW(B ,Lbc(B ,LQP]Tc`c(B -,L1P]Tc`Xab^\(B ,LabPR(B. +-L²×ïÒ ÑØ ï ÑÐÝÔãàã-A +-LÂÐ Ù ×ÐÓàÐÒ, éÞ ×ÝÐÒ.-A +-LÇÕàÕ× âã ÑÐÝÔãàã-A +-L±ÐÝÔãàØáâÞÜ áâÐÒ.-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -1241,12 +1241,12 @@ read the following poem: @example -,FK_co(B ,Faj|la(B -,Fha(B ,Fido}le(B ,Ftir(B ,Falucdaki]r(B ,Fm(B',Famh_foum(B -,Fta(B ,Fl\qlaqa(B ,Fma(B ,Fk\lpoum(B ,Fstom(B ,F^kio(B -,Ftg(B ,Fh\kassa(B ,Fma(B ,Fjulat_fei(B -,Fk_co(B ,Faj|la(B, -,Fma(B ,Fsgjyho}le(B ,Fk_co(B ,Fxgk|teqa(B. +-FËßãï áêüìá-A +-Fèá éäïýìå ôéò áìõãäáëéÝò í'áíèßæïõí-A +-Fôá ìÜñìáñá íá ëÜìðïõí óôïí Þëéï-A +-Fôç èÜëáóóá íá êõìáôßæåé-A +-Fëßãï áêüìá,-A +-Fíá óçêùèïýìå ëßãï øçëüôåñá.-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -1278,7 +1278,7 @@ @subsection Inputing Greek To input Greek characters, use the Quail system. Hit @kbd{C-]} to -turn into quail-mode. If you do not see the string @samp{[,FEkkgmij\(B]} in +turn into quail-mode. If you do not see the string @samp{[-FÅëëçíéêÜ]} in-A the mode-line, then hit @kbd{M-s} and specify the package name @samp{greek}. @key{SPC} works as the completion key. If you hit @key{RET} without specifying a package name, the default package (shown @@ -1288,18 +1288,18 @@ @example 1! 2@ 3# 4$ 5% 6^ 7& 8* 9( 0) -_ =+ `~ - ,F7/(B ,FrS(B ,FeE(B ,FqQ(B ,FtT(B ,FuU(B ,FhH(B ,FiI(B ,FoO(B ,FpP(B [{ ]} - ,FaA(B ,FsS(B ,FdD(B ,FvV(B ,FcC(B ,FgG(B ,FnN(B ,FjJ(B ,FkK(B ,F4((B '" \| - ,FfF(B ,FwW(B ,FxX(B ,FyY(B ,FbB(B ,FmM(B ,FlL(B ,; .: /? + -F·¯ òÓ åÅ ñÑ ôÔ õÕ èÈ éÉ ïÏ ðÐ [{ ]}-A + -FáÁ óÓ äÄ öÖ ãà çÇ îÎ êÊ ëË ´¨ '" \|-A + -FæÆ ÷× øØ ùÙ â íÍ ìÌ ,; .: /? -A @end example - The keys @kbd{,F4(B} (@kbd{;} on ASCII keyboard) and @kbd{,F((B} (@kbd{:} on + The keys @kbd{-F´} (@kbd{;} on ASCII keyboard) and @kbd{¨} (@kbd{:} on-A ASCII keyboard) work as dead keys. For example, @example -@samp{,Fa(B} + @samp{,F4(B} becomes @samp{,F\(B} -@samp{,Fi(B} + @samp{,F((B} becomes @samp{,Fz(B} -@samp{,Fi(B} + @samp{,F((B} + @samp{,F4(B} becomes @samp{,F@(B} +@samp{-Fá} + @samp{´} becomes @samp{Ü}-A +@samp{-Fé} + @samp{¨} becomes @samp{ú}-A +@samp{-Fé} + @samp{¨} + @samp{´} becomes @samp{À}-A @end example To exit quail-mode, hit @kbd{C-]} once again. @@ -1345,7 +1345,7 @@ read the following Hebrew alphabet: @example -[2],H`abcdefghijklmnopqrstuvwxyz[0](B +›2]-Hàáâãäåæçèéêëìíîïðñòóôõö÷øùú›0]-A @end example Bear in mind that all fonts used in Mule must be of fixed width. @@ -1416,10 +1416,10 @@ The Hebrew keymap in quail-mode looks like this: @example -1[2]![0] 2[2]@[0] 3[2]#[0] 4[2]$[0] 5[2]%[0] 6[2]^[0] 7[2]&[0] 8[2]*[0] 9[2]([0] 0[2])[0] [2]-_[0] [2]=+[0] [2];~[0] [2]\|[0] - [2]/[0]Q [2]'[0]W [2],Hw[0](BE [2],Hx[0](BR [2],H`[0](BT [2],Hh[0](BY [2],He[0](BU [2],Ho[0](BI [2],Hm[0](BO [2],Ht[0](BP [2][{[0] [2]]}[0] - [2],Hy[0](BA [2],Hc[0](BS [2],Hb[0](BD [2],Hk[0](BF [2],Hr[0](BG [2],Hi[0](BH [2],Hg[0](BJ [2],Hl[0](BK [2],Hj[0](BL [2],Hs(B:[0] [2],"[0] - [2],Hf[0](BZ [2],Hq[0](BX [2],Ha[0](BC [2],Hd[0](BV [2],Hp[0](BB [2],Hn[0](BN [2],Hv[0](BM [2],Hz(B<[0] [2],Hu(B>[0] [2].?[0] +1! 2@ 3# 4$ 5% 6^ 7& 8* 9( 0) -_ =+ ;~ \| + /Q 'W ›2]-H÷›0]E ›2]ø›0]R ›2]à›0]T ›2]è›0]Y ›2]å›0]U ›2]ï›0]I ›2]í›0]O ›2]ô›0]P [{ ]} -A + ›2]-Hù›0]A ›2]ã›0]S ›2]â›0]D ›2]ë›0]F ›2]ò›0]G ›2]é›0]H ›2]ç›0]J ›2]ì›0]K ›2]ê›0]L ›2]ó›0](B:[0] [2],"[0] -A + [2],H›2]-Hæ›0]Z ›2]ñ›0]X ›2]á›0]C ›2]ä›0]V ›2]ð›0]B ›2]î›0]N ›2]ö›0]M ›2]ú›0](B<[0] [2],H›2]õ›0](B>[0] [2].?[0] -A @end example With @key{SFT} keys, you can input upper case ASCII characters even @@ -1536,7 +1536,7 @@ following famous words: @quotation -[2](3U(4?(3G![;=!8RYa(4Z(3&[0](B +[2](3›2](3U(4?(3G![;=!8RYa(4Z(3&›0](B @end quotation For the Arabic non-spacing marks, only two of them, i.e., hamza and @@ -1575,7 +1575,7 @@ +-------------+ +------------+ C-] +-----------+ @end example - The string @samp{[2](3JG:a=[0](B} in the mode-line indicates that you are in + The string @samp{›2](3JG:a=›0](B} in the mode-line indicates that you are in arabic-mode and the keyboard produces Arabic characters; @samp{Arabic} indicates that you are in arabic-mode and the keyboard produces ASCII characters. @@ -1617,17 +1617,17 @@ +-------------------+ +----------------------------------------------------------------+ -|[2](3"[0](B | | | | | | | |[2](3#[0](B |[2](3$[0](B | | | | +|›2](3"›0](B | | | | | | | |›2](3#›0](B |›2](3$›0](B | | | | |(2"(B 1|(2#(B 2|(2$(B 3|(2%(B 4|(2&(B 5|(2'(B 6|(2((B 7|(2)(B 8|(2*(B 9|(2!(B 0| -| =| `| +----------------------------------------------------------------+ | | | | | | | | | | | | | - |[2](4A[0](B q|[2](4=[0](B w|[2](4S[0](B e|[2](4Q[0](B r|[2](4O[0](B t|[2](4M[0](B y|[2](3Z[0](B u| i|[2](41[0](B o|[2](4-[0](B p|[2](4)[0](B [|[2](4g[0](B ]| + |›2](4A›0](B q|›2](4=›0](B w|›2](4S›0](B e|›2](4Q›0](B r|›2](4O›0](B t|›2](4M›0](B y|›2](3Z›0](B u| i|›2](41›0](B o|›2](4-›0](B p|›2](4)›0](B [|›2](4g›0](B ]| +-------------------------------------------------------------+ - | | | |[2](4e[0](B |[2](3.[0](B | | | | | [2](4k[0](B| |[2](3,[0](B | - |[2](49[0](B a|[2](45[0](B s|[2](4_[0](B d|[2](4#[0](B f|[2](38[0](B g|[2](4%[0](B h|[2](4Y[0](B j|[2](4[[0](B k|[2](3T[0](B l|[2](4U[0](B ;| '| \| + | | | |›2](4e›0](B |›2](3.›0](B | | | | | ›2](4k›0](B| |›2](3,›0](B | + |›2](49›0](B a|›2](45›0](B s|›2](4_›0](B d|›2](4#›0](B f|›2](38›0](B g|›2](4%›0](B h|›2](4Y›0](B j|›2](4[›0](B k|›2](3T›0](B l|›2](4U›0](B ;| '| \| +-----------------------------------------------------------+ - | | | |[2](30[0](B [2](3-[0](B|[2](3h[0](B | | |[2](3*[0](B |[2](3+[0](B |[2](3)[0](B | - |[2](4I[0](B z|[2](4E[0](B x|[2](3D[0](B c|[2](3B[0](B v|[2](3H[0](B b|[2](3F[0](B n|[2](3^[0](B m|[2](3%[0](B ,|[2](3&[0](B .| /| + | | | |›2](30›0](B ›2](3-›0](B|›2](3h›0](B | | |›2](3*›0](B |›2](3+›0](B |›2](3)›0](B | + |›2](4I›0](B z|›2](4E›0](B x|›2](3D›0](B c|›2](3B›0](B v|›2](3H›0](B b|›2](3F›0](B n|›2](3^›0](B m|›2](3%›0](B ,|›2](3&›0](B .| /| +-------------------------------------------------+ @end example @@ -1646,17 +1646,17 @@ Upper : shifted Lower : unshifted +----------------------------------------------------------------+ -|! [2](3"[0](B |@ |# |$ |% |^ |& |* |( [2](3#[0](B |) [2](3$[0](B |_ |+ |~ [2](3+[0](B | -|1 (2"(B |2 (2#(B |3 (2$(B |4 (2%(B |5 (2&(B |6 (2'(B |7 (2((B |8 (2)(B |9 (2*(B |0 (2!(B |- |= |` [2](4M[0](B| +|! ›2](3"›0](B |@ |# |$ |% |^ |& |* |( ›2](3#›0](B |) ›2](3$›0](B |_ |+ |~ ›2](3+›0](B | +|1 (2"(B |2 (2#(B |3 (2$(B |4 (2%(B |5 (2&(B |6 (2'(B |7 (2((B |8 (2)(B |9 (2*(B |0 (2!(B |- |= |` ›2](4M›0](B| +----------------------------------------------------------------+ - |Q |W |E |R |T [2](4E[0](B|Y |U |I |O |P |{ |} | - |q [2](4S[0](B|w [2](3^[0](B |e |r [2](3F[0](B |t [2](4%[0](B|y [2](4_[0](B|u |i |o [2](3<[0](B |p |[ |] | + |Q |W |E |R |T ›2](4E›0](B|Y |U |I |O |P |{ |} | + |q ›2](4S›0](B|w ›2](3^›0](B |e |r ›2](3F›0](B |t ›2](4%›0](B|y ›2](4_›0](B|u |i |o ›2](3<›0](B |p |[ |] | +-------------------------------------------------------------+ - |A [2](4][0](B|S [2](4=[0](B|D [2](4A[0](B|F |G [2](4O[0](B|H [2](4-[0](B|J |K [2](41[0](B|L |: [2](3'[0](B |" [2](3-[0](B || [2](3,[0](B | - |a [2](38[0](B |s [2](45[0](B|d [2](3B[0](B |f [2](4Q[0](B|g |h [2](3Z[0](B |j [2](4)[0](B|k [2](4U[0](B|l [2](4Y[0](B|; [2](3([0](B |' [2](3*[0](B |\ | + |A ›2](4]›0](B|S ›2](4=›0](B|D ›2](4A›0](B|F |G ›2](4O›0](B|H ›2](4-›0](B|J |K ›2](41›0](B|L |: ›2](3'›0](B |" ›2](3-›0](B || ›2](3,›0](B | + |a ›2](38›0](B |s ›2](45›0](B|d ›2](3B›0](B |f ›2](4Q›0](B|g |h ›2](3Z›0](B |j ›2](4)›0](B|k ›2](4U›0](B|l ›2](4Y›0](B|; ›2](3(›0](B |' ›2](3*›0](B |\ | +-----------------------------------------------------------+ - |Z [2](4I[0](B|X |C |V |B |N |M |< |> |? [2](3)[0](B | - |z [2](3H[0](B |x [2](3D[0](B |c [2](4'[0](B|v |b [2](4#[0](B|n [2](4[[0](B|m [2](3T[0](B |, [2](3%[0](B |. [2](3&[0](B |/ [2](49[0](B| + |Z ›2](4I›0](B|X |C |V |B |N |M |< |> |? ›2](3)›0](B | + |z ›2](3H›0](B |x ›2](3D›0](B |c ›2](4'›0](B|v |b ›2](4#›0](B|n ›2](4[›0](B|m ›2](3T›0](B |, ›2](3%›0](B |. ›2](3&›0](B |/ ›2](49›0](B| +-------------------------------------------------+ COMBINATIONS: @@ -2532,7 +2532,7 @@ read the following line: @quotation -,0I!J(B ,0!K(B ,0'(B ,0Z% S(B ,0V!BS(B ,0!S(B ,0p% p@ rp" (B ,0Dp$V'DB'K(B +-0É¡Ê ¡Ë § Ú¥ Ó Ö¡ÂÓ ¡Ó ð¥ ðÀ ò𢠠Äð¤Ö§Ä§Ë-A @end quotation Bear in mind that all fonts used in Mule must be of fixed width. diff -r 498bf5da1c90 -r 0d2f883870bc man/tm/tm-view-en.sgml --- a/man/tm/tm-view-en.sgml Mon Aug 13 09:12:43 2007 +0200 +++ b/man/tm/tm-view-en.sgml Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ - + -tm-view 7.79 Reference Manual (English Version) +<title>tm-view 7.80 Reference Manual (English Version) <author>MORIOKA Tomohiko <mail>morioka@jaist.ac.jp</mail> -<date>1996/12/25 +<date>1997/1/31 <toc> </head> @@ -353,10 +353,18 @@ <kd> goes to the previous content </kd> +<kt>M-TAB +<kd> +goes to the previous content +</kd> <kt>n <kd> goes to the next content </kd> +<kt>TAB +<kd> +goes to the next content +</kd> <kt>SPC <kd> scrolls up diff -r 498bf5da1c90 -r 0d2f883870bc man/tm/tm-view-en.texi --- a/man/tm/tm-view-en.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/tm/tm-view-en.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,13 +1,13 @@ \input texinfo.tex @setfilename tm-view-en.info -@settitle{tm-view 7.79 Reference Manual (English Version)} +@settitle{tm-view 7.80 Reference Manual (English Version)} @titlepage -@title tm-view 7.79 Reference Manual (English Version) +@title tm-view 7.80 Reference Manual (English Version) @author MORIOKA Tomohiko <morioka@@jaist.ac.jp> -@subtitle 1996/12/25 +@subtitle 1997/1/31 @end titlepage @node Top, Introduction, (dir), (dir) -@top tm-view 7.79 Reference Manual (English Version) +@top tm-view 7.80 Reference Manual (English Version) @ifinfo @@ -379,9 +379,15 @@ @item @key{p} goes to the previous content +@item @key{M-TAB} +goes to the previous content + @item @key{n} goes to the next content +@item @key{TAB} +goes to the next content + @item @key{SPC} scrolls up diff -r 498bf5da1c90 -r 0d2f883870bc man/tm/tm-view-ja.sgml --- a/man/tm/tm-view-ja.sgml Mon Aug 13 09:12:43 2007 +0200 +++ b/man/tm/tm-view-ja.sgml Mon Aug 13 09:13:56 2007 +0200 @@ -1,9 +1,9 @@ <!doctype sinfo system> -<!-- $Id: tm-view-ja.sgml,v 1.2 1996/12/28 21:03:33 steve Exp $ --> +<!-- $Id: tm-view-ja.sgml,v 1.3 1997/02/15 22:22:04 steve Exp $ --> <head> -<title>tm-view 7.79 Reference Manual$B!JF|K\8lHG!K(B +<title>tm-view 7.80 Reference Manual$B!JF|K\8lHG!K(B <author>$B<i2,(B $BCNI'(B <mail>morioka@jaist.ac.jp</mail> -<date>1996/12/25 +<date>1997/1/31 <toc> </head> @@ -343,8 +343,12 @@ </kd> <kt>p<kd>$BA0$N(B part $B$K0\F0$9$k(B </kd> +<kt>M-TAB<kd>$BA0$N(B part $B$K0\F0$9$k(B +</kd> <kt>n<kd>$B<!$N(B part $B$K0\F0$9$k(B </kd> +<kt>TAB<kd>$B<!$N(B part $B$K0\F0$9$k(B +</kd> <kt>SPC<kd>scroll up $B$9$k(B </kd> <kt>M-SPC<kd>scroll down $B$9$k(B diff -r 498bf5da1c90 -r 0d2f883870bc man/tm/tm-view-ja.texi --- a/man/tm/tm-view-ja.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/tm/tm-view-ja.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,13 +1,13 @@ \input texinfo.tex @setfilename tm-view-ja.info -@settitle{tm-view 7.79 Reference Manual$B!JF|K\8lHG!K(B} +@settitle{tm-view 7.80 Reference Manual$B!JF|K\8lHG!K(B} @titlepage -@title tm-view 7.79 Reference Manual$B!JF|K\8lHG!K(B +@title tm-view 7.80 Reference Manual$B!JF|K\8lHG!K(B @author $B<i2,(B $BCNI'(B <morioka@@jaist.ac.jp> -@subtitle 1996/12/25 +@subtitle 1997/1/31 @end titlepage @node Top, Introduction, (dir), (dir) -@top tm-view 7.79 Reference Manual$B!JF|K\8lHG!K(B +@top tm-view 7.80 Reference Manual$B!JF|K\8lHG!K(B @ifinfo @@ -375,9 +375,15 @@ @item @key{p} $BA0$N(B part $B$K0\F0$9$k(B +@item @key{M-TAB} +$BA0$N(B part $B$K0\F0$9$k(B + @item @key{n} $B<!$N(B part $B$K0\F0$9$k(B +@item @key{TAB} +$B<!$N(B part $B$K0\F0$9$k(B + @item @key{SPC} scroll up $B$9$k(B diff -r 498bf5da1c90 -r 0d2f883870bc man/vm.texi --- a/man/vm.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/vm.texi Mon Aug 13 09:13:56 2007 +0200 @@ -433,9 +433,9 @@ version of the folder until the folder is saved.@refill Typing @kbd{h} (@code{vm-summarize}) causes VM to pop up a window -containing a summary of contents of the current folder. The summary is +containing a summary of the contents of the current folder. The summary is presented one line per message, by message number, listing each message's -author, date sent, line and byte count, and subject. Also various +author, date sent, line and byte count, and subject. Also, various letters appear beside the message number to indicate that a message is new, unread, flagged for deletion, etc. An arrow @samp{->} appears to the left of the line summarizing the current message. The summary @@ -487,7 +487,7 @@ file. Since VM has in excess of forty configuration variables, use of the @file{~/.vm} can considerably reduce clutter in the @file{.emacs} file. You can force the reloading of this file on demand by typing -@kbd{L} from within VM.@refill +@kbd{L} (@code{vm-load-init-file}) from within VM.@refill @findex vm @vindex vm-primary-inbox @@ -545,15 +545,15 @@ The variable @code{vm-startup-with-summary} controls whether VM automatically displays a summary of the folder's contents at startup. A value of @code{nil} gives no summary; a value of @code{t} gives a full -screen summary. A value that is neither @code{t} nor @code{nil} splits -the screen between the summary and the folder display. The latter only +frame summary. A value that is neither @code{t} nor @code{nil} splits +the frame between the summary and the folder display. The latter only works if the variable @code{pop-up-windows}'s value is non-@code{nil}, and the value of @code{vm-mutable-windows} is non-@code{nil}. The default value of @code{vm-startup-with-summary} is @code{nil}.@refill @vindex vm-mail-window-percentage The variable @code{vm-mail-window-percentage} tells VM what percentage of -the screen should be given to the folder display when both it and the +the frame should be given to the folder display when both it and the folder summary are being displayed. Note that Emacs enforces a minimum window size limit, so a very high or very low value for this variable may squeeze out one of the displays entirely. This variable's default @@ -583,7 +583,7 @@ (@code{vm-next-message}) and @kbd{p} (@code{vm-previous-message}). These commands move forward and backward through the current folder. When they go beyond the end or beginning of the folder they wrap to the -beginning and end respectively. By default these commands skip messages +beginning and end respectively. By default, these commands skip messages flagged for deletion. This behavior can be disabled by setting the value of the variable @code{vm-skip-deleted-messages} to @code{nil}. These commands can also be made to skip messages that have been read; set @@ -616,12 +616,7 @@ Other commands to select messages: -@iftex -@table @asis -@end iftex -@ifinfo -@table @key -@end ifinfo +@table @kbd @findex vm-goto-message @kindex RET @item RET (@code{vm-goto-message}) @@ -668,7 +663,7 @@ @node Reading Messages, Sending Messages, Selecting Messages, Top @chapter Reading Messages -Once a message has been selected, VM will present it to you. By default +Once a message has been selected, VM will present it to you. By default, presentation is done in two stages: @dfn{previewing} and @dfn{paging}. @menu @@ -684,9 +679,9 @@ @key{SPC} exposes the body of the message, and from there you can repeatedly type @key{SPC} to page through the message. -By default the sender, recipient, subject and date headers are shown +By default, the sender, recipient, subject and date headers are shown when previewing; the rest of the message is hidden. This behavior may -be altered by changing the settings of two variables: +be altered by changing the settings of three variables: @code{vm-visible-headers}, @code{vm-invisible-header-regexp} and @code{vm-preview-lines}.@refill @@ -731,7 +726,7 @@ causes the From and Subject headers to be highlighted.@refill @vindex vm-preview-read-messages -By default VM previews all messages, even if they have already been read. +By default, VM previews all messages, even if they have already been read. To have VM preview only those messages that have not been read, set the value of @code{vm-preview-read-messages} to @code{nil}. @@ -770,17 +765,12 @@ GNU Emacs Manual}. However, @samp{*mail*} buffers created by VM have extra command keys: -@iftex -@table @asis -@end iftex -@ifinfo -@table @key -@end ifinfo +@table @kbd @findex vm-yank-message @kindex C-c C-y @item C-c C-y (@code{vm-yank-message}) Copies a message from the current folder into the @samp{*mail*} buffer. -The message number is read from the minibuffer. By default each line of +The message number is read from the minibuffer. By default, each line of the copy is prepended with the value of the variable @code{vm-included-text-prefix}. All message headers are yanked along with the text. Point is left before the inserted text, the mark after. @@ -808,12 +798,12 @@ described above. @code{vm-mail} can be invoked outside of VM by typing @kbd{M-x vm-mail}. -However, of the above commands, only @key{C-c y} +However, of the above commands, only @kbd{C-c y} (@code{vm-yank-message-other-folder}) will work; all the other commands require a parent folder.@refill If you send a message and it is returned by the mail system because it -was undeliverable, you an easily resend the message by typing @kbd{M-r} +was undeliverable, you can easily resend the message by typing @kbd{M-r} (@code{vm-resend-bounced-message}). VM will extract the old message and its pertinent headers from the returned message, and place you in a @samp{*mail*} buffer. You can then change the recipient addresses or do @@ -830,7 +820,7 @@ @vindex vm-reply-subject-prefix VM has special commands that make it easy to reply to a message. When a -reply command is invoked VM fills in the subject and recipient headers +reply command is invoked, VM fills in the subject and recipient headers for you, since it is apparent to whom the message should be sent and what the subject should be. There is an old convention of prepending the string @samp{"Re: "} to the subject of replies if the string isn't @@ -877,12 +867,7 @@ The reply commands are: -@iftex -@table @asis -@end iftex -@ifinfo -@table @key -@end ifinfo +@table @kbd @findex vm-reply @kindex r @item r (@code{vm-reply}) @@ -932,7 +917,7 @@ except the current message appears as the body of the message in the @samp{*mail*} buffer. The forwarded message is surrounded by RFC 934 compliant message delimiters. If the variable -@code{vm-rfc934-forwarding} is non-@code{nil} "^-" to "- -" character +@code{vm-rfc934-forwarding} is non-@code{nil}, "^-" to "- -" character stuffing is done to the forwarded message (this is the default). This behavior is required if the recipient of the forwarded message wants to use a RFC 934 standard bursting agent to access the message. If the @@ -1009,13 +994,13 @@ the default when prompting for a folder to save the message in. If the resulting folder name is a relative pathname it resolves to the directory named by @code{vm-folder-directory}, or the @code{default-directory} of -the currently visited folder if @code{vm-folder-directory} is nil.@refill +the currently visited folder if @code{vm-folder-directory} is @code{nil}.@refill When @var{folder-name} is evaluated, the current buffer will contain only the contents of the header named by @var{header-name}. It is safe to modify this buffer. You can use the match data from any @samp{\( @dots{} \)} grouping constructs in @var{regexp} along with the function -buffer-substring to build a folder name based on the header information. +@code{buffer-substring} to build a folder name based on the header information. If the result of evaluating @var{folder-name} is a list, then the list will be treated as another auto-folder-alist and will be descended recursively.@refill @@ -1047,18 +1032,13 @@ @vindex vm-delete-after-saving After a message is saved to a folder, the usual thing to do next is to delete it. If the variable @code{vm-delete-after-saving} is -non-@code{nil} VM will flag messages for deletion automatically after -saving them. This applies only to saves to folders, not for the @key{w} +non-@code{nil}, VM will flag messages for deletion automatically after +saving them. This applies only to saves to folders, not for the @kbd{w} command (see below).@refill Other commands: -@iftex -@table @asis -@end iftex -@ifinfo -@table @key -@end ifinfo +@table @kbd @findex vm-save-message-sans-headers @kindex w @item w (@code{vm-save-message-sans-headers}) @@ -1075,8 +1055,8 @@ @findex vm-pipe-message-to-command @kindex | @item | (@code{vm-pipe-message-to-command}) -Runs a shell command with the some or all of the current message as input. -By default the entire message is used.@* +Runs a shell command with some or all of the current message as input. +By default, the entire message is used.@* @* If invoked with one @t{C-u} the text portion of the message is used.@* If invoked with two @t{C-u}'s the header portion of the message is used.@* @@ -1092,12 +1072,7 @@ @dfn{expunged} or removed from the folder. The messages are not removed from the on-disk copy of the folder until the folder is saved. -@iftex -@table @asis -@end iftex -@ifinfo -@table @key -@end ifinfo +@table @kbd @findex vm-delete-message @kindex d @item d (@code{vm-delete-message}) @@ -1115,7 +1090,7 @@ @findex vm-kill-subject @kindex k @item k (@code{vm-kill-subject}) -Flags all message with the same subject as the current message (ignoring +Flags all messages with the same subject as the current message (ignoring ``Re:'') for deletion. @findex vm-expunge-folder @kindex # @@ -1166,17 +1141,17 @@ messages in the summary window.@refill To remove a mark from the current message, use @kbd{C-c SPC} -(@code{vm-unmark-message}. Prefix arguments work as with +(@code{vm-unmark-message}). Prefix arguments work as with @code{vm-mark-message}.@refill -Use @kbd{C-c C-a} to mark all message in the current folder; @kbd{C-c a} +Use @kbd{C-c C-a} to mark all messages in the current folder; @kbd{C-c a} removes marks from all messages. To apply a VM command to all marked message you must prefix it with the key sequence @kbd{C-c RET} (@code{vm-next-command-uses-marks}). The next VM command will apply to all marked messages, provided the command can be applied to such messages in a meaningful and useful way. -The current commands that can be applied to marked message are: +The current commands that can be applied to marked messages are: @code{vm-delete-message}, @code{vm-discard-cached-data}, @code{vm-followup}, @code{vm-followup-include-text}, @code{vm-reply}, @code{vm-reply-include-text}, @code{vm-save-message}, @@ -1207,7 +1182,7 @@ @kindex G In order to make numerous related messages easier to cope with, VM provides the command @kbd{G} (@code{vm-group-messages}), which groups -all message in a folder according to some criterion. @dfn{Grouping} +all messages in a folder according to some criterion. @dfn{Grouping} causes messages that are related in some way to be presented consecutively. The actual order of the folder is not altered; the messages are simply numbered and presented differently. Grouping @@ -1235,8 +1210,8 @@ If the variable @code{vm-group-by} has a non-@code{nil} value it specifies the default grouping that will be used for all folders. So if you like having your mail presented to you grouped by subject, then put -@code{(setq vm-group-by "subject")} in your @file{.emacs} file to get this -behavior.@refill +@code{(setq vm-group-by "subject")} in your @file{.vm} or @file{.emacs} +file to get this behavior.@refill @node Reading Digests, Summaries, Grouping Messages, Top @chapter Reading Digests @@ -1250,7 +1225,7 @@ @findex vm-burst-digest @kindex * The command @kbd{*} (@code{vm-burst-digest}) bursts a digest into its -individual messages and appends them to current folder. These +individual messages and appends them to the current folder. These messages are then assimilated into the current folder using the default grouping. @xref{Grouping Messages}. The original digest message is not altered, and the messages extracted from it are not part of the on-disk copy @@ -1274,10 +1249,11 @@ arrow @samp{->} appears to the left of the line summarizing the current message. The variable @code{vm-auto-center-summary} controls whether VM will keep the summary arrow vertically centered within the summary -window. A value of @code{t} causes VM to always keep arrow centered. A -value of @code{nil} means VM will never bother centering the arrow. A -value that is not @code{nil} and not @code{t} causes VM to center the -arrow only if the summary window is not the only existing window.@refill +window. A value of @code{t} causes VM to always keep the arrow +centered. A value of @code{nil} (the default) means VM will never +bother centering the arrow. A value that is not @code{nil} and not +@code{t} causes VM to center the arrow only if the summary window is not +the only existing window.@refill @vindex vm-summary-format The variable @code{vm-summary-format} controls the format of each @@ -1355,20 +1331,15 @@ Here are some VM customization variables that don't really fit into the other chapters. -@iftex -@table @asis -@end iftex -@ifinfo @table @code -@end ifinfo @vindex vm-confirm-quit @item vm-confirm-quit -A value of t causes VM to always ask for confirmation before ending -a VM visit of a folder. A nil value means VM will ask only when messages -will be lost unwittingly by quitting, i.e. not removed by intentional -delete and expunge. A value that is not nil and not t causes VM to ask -only when there are unsaved changes to message attributes or message -will be lost. +A value of @code{t} causes VM to always ask for confirmation before +ending a VM visit of a folder. A @code{nil} value means VM will ask +only when messages will be lost unwittingly by quitting, i.e. not +removed by intentional delete and expunge. A value that is neither +@code{nil} nor @code{t} causes VM to ask only when there are unsaved +changes to message attributes or message will be lost. @vindex vm-berkeley-mail-compatibility @item vm-berkeley-mail-compatibility A non-@code{nil} value means to read and write BSD @i{Mail(1)} style Status: @@ -1392,7 +1363,7 @@ @vindex vm-mutable-windows @item vm-mutable-windows This variable's value controls VM's window usage. A value of @code{t} gives VM -free run of the Emacs display; it will commandeer the entire screen for +free run of the Emacs display; it will commandeer the entire frame for its purposes. A value of @code{nil} restricts VM's window usage to the window from which it was invoked. VM will not create, delete, or use any other windows, nor will it resize its own window. A value that is neither @code{t} diff -r 498bf5da1c90 -r 0d2f883870bc man/w3.texi --- a/man/w3.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/w3.texi Mon Aug 13 09:13:56 2007 +0200 @@ -1,4 +1,16 @@ \input texinfo +@c +@c Please note that this file uses some constructs not supported by earlier +@c versions of TeXinfo. You must be running one of the newer TeXinfo +@c releases (I currently use version 3.9 from ftp://prep.ai.mit.edu/pub/gnu +@c +@c Please do not send in bug reports about not being able to format the +@c document with 'makeinfo' or 'tex', just upgrade your installation. +@c +@c Info formatted files are provided in the distribution, and you can +@c retrieve dvi, postscript, and PDF versions from the web site or ftp +@c site: http://www.cs.indiana.edu/elisp/w3/docs.html +@c @setfilename w3.info @settitle Emacs-W3 User's Manual @iftex @@ -20,8 +32,8 @@ @ifinfo This file documents the Emacs-W3 World Wide Web browser. -Copyright (C) 1993, 1994, 1995 William M. Perry -Copyright (C) 1996 Free Software Foundation +Copyright (C) 1993, 1994, 1995, 1996 William M. Perry +Copyright (C) 1996, 1997 Free Software Foundation Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -43,14 +55,14 @@ @sp 4 @center Third Edition, Emacs-W3 Version 3.0 @sp 1 -@center December 1996 +@center February 1997 @sp 5 @center William M. Perry @center @i{wmperry@@cs.indiana.edu} @page @vskip 0pt plus 1filll Copyright @copyright{} 1993, 1994, 1995 William M. Perry@* -Copyright @copyright{} 1996 Free Software Foundation +Copyright @copyright{} 1996, 1997 Free Software Foundation Permission is granted to make and distribute verbatim copies of@* this manual provided the copyright notice and this permission notice@* @@ -59,559 +71,130 @@ @end titlepage @page @ifinfo -@node Top, Introduction,, (DIR) -This manual documents the Emacs-W3 World Wide Web browser, a Lisp program -which runs as a subsystem under Emacs. The manual is divided into the -following chapters. +@node Top, Getting Started,, (DIR) +Users can browse the World Wide Web from within Emacs by using Emacs-W3. +All of the widely used (and even some not very widely used) @sc{url} +schemes are supported, and it is very easy to add new methods as the +need arises. + +Emacs-W3 provides some core functionality that can be readily re-used +from any program in Emacs. Users and other package writers are +encouraged to @i{Web-enable} their applications and daily work routines +with the library. + +Emacs-W3 is completely customizable, both from Emacs-Lisp and from +stylesheets @xref{Style Sheets} If there is any aspect of Emacs-W3 that +cannot be modified to your satisfaction, please send mail to the +@t{w3-beta@@indiana.edu} mailing list with any suggestions. +@xref{Reporting Bugs} @menu -* Introduction:: Overview of Emacs-W3. * Getting Started:: Getting up and running with Emacs-W3 * Basic Usage:: Basic movement and usage of Emacs-W3. * Compatibility:: Explanation of compatibility with - other web browsers. -* Controlling Formatting:: How to control HTML formatting -* MIME Support:: Support for MIME -* Security:: Various forms of security + other browsers. +* Stylesheets:: How to control the look of web pages +* Supported URLs:: What @sc{URL} schemes are supported. +* MIME Support:: Support for @sc{mime} +* Security:: Various security methods supported * Non-Unix Operating Systems:: Special considerations necessary to get up and running correctly under non-unix OS's. +* Speech Integration:: Outputting to a speech synthesizer. * Advanced Features:: Some of the more arcane features. * More Help:: How to get more help---mailing lists, newsgroups, etc. * Future Directions:: Plans for future revisions Appendices: -* Reporting Bugs:: How to report a bug in Emacs-W3 -* Installing SSL:: Turning on SSL support -* Using PGP/PEM:: Turning on PGP/PEM encryption support -* Mailcap Files:: An explanation of Mailcap files +* Reporting Bugs:: How to report a bug in Emacs-W3. +* Dealing with Firewalls:: How to get around your firewall. +* Proxy Gateways:: Using a proxy gateway with Emacs-W3. +* Installing SSL:: Turning on @sc{ssl} support. +* Mailcap Files:: An explanation of Mailcap files. +* Down with DoubleClick:: Annoyed by advertisements? Read this! Indices: -* General Index:: General Index -* Key Index:: Menus of command keys and their references -@end menu -@end ifinfo - -@node Introduction, Getting Started, Top, Top -@chapter Introduction -@cindex World Wide Web - -:: WORK :: Basic info on what Emacs-W3 is, including copyrights, etc. - -@ifinfo -Here is some more specific information about what languages and -protocols Emacs-W3 supports. -@menu -* Markup Languages Supported:: Markup languages supported by Emacs-W3 -* Stylesheets:: Stylesheet languages supported by Emacs-W3 -* Supported Protocols:: Network protocols supported by Emacs-W3 -@end menu -@end ifinfo -@node Markup Languages Supported, Stylesheets, Introduction, Introduction -@chapter Supported Markup Languages -Several different markup languages, and various extensions to those -languages, are supported by Emacs-W3. -@ifinfo -@center ---------- -@center HTML 2.0 -@center ---------- -@end ifinfo -@iftex -@section HTML 2.0 -@end iftex -@cindex HTML 2.0 - -:: WORK :: Reference to the HTML 2.0 RFC -:: WORK :: Basic explanation of HTML, tag structure, etc. - -@ifinfo -@center ---------- -@center HTML 3.2 -@center ---------- -@end ifinfo -@iftex -@section HTML 3.2 -@end iftex -@cindex HTML 3.2 -The HTML 3.2 language is an extension of HTML, with a large degree of -backward compatibility with HTML 2.0. This basically documents current -practice as of January, 1996. - -@ifinfo -@center ---------- -@center SGML Features -@center ---------- -@end ifinfo -@iftex -@section SGML Features -@end iftex -@cindex SGML Features -@cindex Entity Definitions -@cindex Marked Sections - -:: WORK :: Document marked sections, SGML features - -@ifinfo -@center ---------- -@center Extras -@center ---------- -@end ifinfo -@iftex -@section Extra Markup -@end iftex -@cindex Easter Eggs -@cindex Fluff -@cindex Pomp & Circumstance -There are several different markup elements that are not officially part -of HTML or HTML 3.2 that Emacs-W3 supports. These are either items that -were dropped from HTML 3.@var{x} after I had implemented them, things I -find just completely hilarious, or experimental parts of HTML that -should not be counted as "official" or long lived. -@itemize @bullet -@item -FLAME support. For truly interesting dynamic documents. This is -replaced with a random quote from Mr. Angry (see @kbd{M-x flame} for a -sample). -@item -The top ten tags that did not make it into netscape. These tags were -posted to the newsgroup comp.infosystems.www.misc by Laura Lemay -(@i{lemay@@netcom.com}). Much thanks to her for the humor. -@table @b -@item <wired>...</wired> -Renders the enclosed text in a suitably ugly font/color combination. If -no default has been set up by the user, this is the default font, with -red text on a yellow background. -@item <roach>...</roach> -When selected, the enclosed text runs and hides under the nearest -window. OR, giggles a lot and demands nachos, depending on the -definition of "roach." (the formal definition, of course, to be -determined by the Official Honorary Internet Standards Committee For -Moving Really Slowly.) -@item <pinhead> -Inserts "zippyisms" into the enclosed text. Perfect for those professional -documents. This is sure to be a favorite of mine! -@item <secret>...</secret> -Must use secret spy decoder glasses (available direct from Netscape for -a reasonable fee) in order to read the enclosed text. Can also be read -by holding the computer in front of a full moon during the autumn -solstice. - -In Emacs-W3, this displays the text using rot13 encoding. -@item <hype> -Causes Marc Andreesen to magically appear and grant an interview (wanted -or not). Please use this tag sparingly. -@item <peek>....</peek> -@item <poke>...</poke> -Need more control over screen layout in HTML? Well, here ya go. -n -Actually, <peek> could almost be considered useful. The VARIABLE -attribute can be used to insert the value of an emacs variable into the -current document. Things like 'Welcome to my page, <peek -variable=user-mail-address>' can be useful in spreading fear, -uncertainty, and doubt among users. -@item <yogsothoth> -@cindex Gates Bill -@cindex Yogsothoth -Summons the elder gods to suck away your immortal soul. Or Bill Gates, -if the elder gods are busy. Unpredictable (but amusing) results occur -when the <YOGSOTHOTH> and <HYPE> tags are used in close proximity. - -@item <blink>...</blink> -Causes the enclosed text to .... ooops that one made it in. -@end table -@end itemize - -@node Stylesheets, Supported Protocols, Markup Languages Supported,Introduction -@chapter Stylesheets -@cindex Stylesheets -@cindex Cascading Style Sheets -@cindex Aural Cascading Style Sheets -@cindex CSS -@cindex DSSSL -:: WORK :: Document CSS support -CSS Information at http://www.w3.org/pub/WWW/TR/REC-CSS1 -Style guide at http://www.htmlhelp.com/reference/css/ -:: WORK :: Document ACSS support -ACSS Information at http://www.w3.org/pub/WWW/Style/CSS/Speech/NOTE-ACSS -:: WORK :: Document DSSSL support - -@node Supported Protocols, , Stylesheets, Introduction -@chapter Supported Protocols -@cindex Network Protocols -@cindex Protocols Supported -@cindex Supported Protocols -Emacs-W3 supports the following protocols -@table @b -@item Usenet News -Can either display an entire newsgroup or specific articles by -Message-ID: header. Instead of rewriting a newsreader, this integrates -with the Gnus newsreader. It requires at least Gnus 5.0, but it is -always safest to use the latest version. Gnus supports some very -advanced features, including virtual newsgroups, mail and news -integration, and reading news from multiple servers. @inforef{Gnus, -Top,gnus}, for more info. - -To be more in line with the other URL schemes, the hostname and port of -an NNTP server can be specified. URLs of the form -news://hostname:port/messageID work, but might not work in some other -browsers. - -@item HTTP -Supports the HTTP/0.9, HTTP/1.0, and parts of the HTTP/1.1 protocols. -@item Gopher -Support for all gopher types, including CSO queries. -@item Gopher+ -Support for Gopher+ retrievals. Support for converting ASK blocks into -HTML 3.0 FORMS and submitting them back to the server. -@item FTP -FTP is handled by either ange-ftp or efs. -@inforef{Ange-FTP,Top,ange-ftp}, for more information on Ange-FTP, or -@inforef{EFS, Top,efs}, for information on EFS. -@item Local files -Local files are of course handled, and MIME content-types are derived -from the file extensions. -@item telnet, tn3270, rlogin -Telnet, tn3270, and rogin are handled by running the appropriate program -in an emacs buffer, or running an external process. -@item mailto -Causes a mail message to be started to a specific address. Supports the -Netscape @i{extensions} to specify arbitrary headers on the message. -@item data -A quick and easy way to `inline' small pieces of information that you do -not necessarily want to download over the net separately. Can speed up -display of small icons, stylesheet information, etc. See the internet -draft draft-masinter-url-data-02.txt for more information. -@item mailserver -A more powerful version of mailto, which allows the author to specify -the subject and body text of the mail message. This type of link is -never fully executed without user confirmation, because it is possible -to insert insulting or threatening (and possibly illegal) data into the -message. The mail message is displayed, and the user must confirm the -message before it is sent. -@item x-exec -A URL can cause a local executable to be run, and its output interpreted -as if it had come from an HTTP server. This is very useful, but is -still an experimental protocol, hence the X- prefix. This URL protocol -is deprecated, but might be useful in the future. -@item NFS -Retrieves information over NFS. This requires that your operating -system support auto-mounting of NFS volumes. -@item finger -Retrieves information about a user via the 'finger' protocol. -@item Info -Creates a link to an GNU-style info file. @inforef{Info,Top,info}, for more -information on the Info format. -@item SSL -SSL requires a set of patches to the Emacs C code and SSLRef 2.0, or an -external program to run in a subprocess (similar to the @file{tcp.el} -package that comes with GNUS. @xref{Installing SSL} -@end table - -@node Getting Started, Getting Emacs, Introduction, Top -@chapter Getting Started -@cindex Clueless in Seattle -@cindex Getting Started -This section of the manual deals with getting, compiling, and -configuring @i{Emacs-W3}. -:: WORK :: Introduction to 'Getting Started' - -@ifinfo -@menu -* Getting Emacs:: Where to get Emacs -* Getting Emacs-W3:: Where to get Emacs-W3 -* Basic Setup:: Basic setup that most people want to do -* Firewalls:: Integrating Emacs-W3 with a firewall setup. -* Proxy Gateways:: Using a proxy server +* General Index:: General Index. +* Key Index:: Menus of command keys and their references. @end menu @end ifinfo -@node Getting Emacs, Getting Emacs-W3, Getting Started, Getting Started -@section Getting Emacs -@cindex Getting Emacs -@cindex Source code availability -:: WORK :: Explanation of Emacs, XEmacs, and where to get both - -@node Getting Emacs-W3, Basic Setup, Getting Emacs, Getting Started -@section Getting Emacs-W3 -@cindex FTP'in the distribution -@cindex Source code availability -:: WORK :: Explanation of Emacs, XEmacs, and where to get both - -@node Basic Setup, Firewalls, Getting Emacs-W3, Getting Started -@section Basic Setup -For most people, Emacs-W3 will be ready to run straight out of the box. -Once the user is more familiar with the web and how it integrates with -Emacs, there are a few basic configuration variables that most people -will want to personalize. - -@table @code -@item w3-default-homepage +@node Getting Started, Basic Usage, Top, Top +@chapter Getting Started +@cindex Clueless in Seattle +@cindex Getting Started +@kindex M-x w3 @vindex w3-default-homepage -The URL to open at startup. This defaults to the environment variable -WWW_HOME if it is not set it in the users @file{.emacs} file. If -WWW_HOME is undefined, then it defaults to the hypertext documentation -for Emacs-W3. +@findex w3 +If installed correctly, starting Emacs-W3 is quite painless. Just type +@kbd{M-x w3} in a running Emacs sessions. This will retrieve the +default page that has been configured - by default the documentation for +Emacs-W3 at Indiana University. -@item w3-delay-image-loads -@vindex w3-delay-image-loads -Controls the loading of inlined images. If non-@code{nil}, images are -not loaded. If the correct image converters are not installed or the -network connection is very slow, it is best to set this to @code{t}. -Defaults to @code{nil}. -@item url-global-history-file -@vindex url-global-history-file -The global history file used by both Mosaic/X and Emacs-W3. This file -contains a list of all the URLs that have been visited. This file is parsed -at startup and used to provide URL completion. Emacs-W3 can read and -write Mosaic/X or Netscape 1.x style history files, or use its own -internal format (faster). The file type is determined automatically, or -prompted for if the file does not exist. -@item w3-hotlist-file -@vindex w3-hotlist-file -Hotlist filename. This should be the name of a file that is stored in -NCSA's Mosaic/X or Netscape's format. It is used to keep a listing of -commonly accessed URLs. -@item w3-personal-annotation-directory -@vindex w3-personal-annotation-directory -The directory where Emacs-W3 looks for personal annotations. This is a -directory that should hold the personal annotations stored in a -Mosaic/X-compatible format. -@item url-pgp/pem-entity -@findex user-real-login-name -@findex system-name -The name by which the user is known to PGP and/or PEM entities. If this -is not set when Emacs-W3 is loaded, it defaults to -@code{user-mail-address} if it is set, otherwise @code{(user-real-login-name)}@@@code{(system-name)}. -@item url-personal-mail-address -@vindex url-personal-mail-address -@vindex url-pgp/pem-entity -User's full email address. This is what is sent to HTTP/1.0 servers as -the FROM header. If this is not set when Emacs-W3 is loaded, then it -defaults to the value of @code{url-pgp/pem-entity}. +If the default page is not retrieved correctly at startup, you will have +to do some customization. -@item w3-right-border -@vindex w3-right-border -@findex window-width -Amount of space to leave on right margin of WWW buffers. This amount is -subtracted from the width of the window for each new WWW buffer and used -as the new @code{fill-column}. +@menu +* Downloading:: Where to download Emacs-W3. +* Building and Installing:: Compiling and installing from source. +* Startup Files:: What is where, and why. +* Preferences Panel:: Quick configuration of common options. +@end menu -@item w3-track-mouse -@vindex w3-track-mouse -Controls whether to track the mouse and message the url under the mouse. -If this is non-@code{nil}, then a description of the hypertext area -under the mouse is shown in the minibuffer. This shows what type of -link (inlined image, form entry area, delayed image, delayed MPEG, or -hypertext reference) is under the cursor, and the destination. -@item w3-echo-link -@vindex w3-echo-link -Controls how a URL is shown when a link is reached with @key{f}, -@key{b}, or the mouse moves over it. Possible values are: -@table @b -@item url -Displays the URL (ie: @samp{http://www.cs.indiana.edu/}). -@item text -Displays the text of the link (ie: @samp{A link to Indiana University}). -@item title -Displays the title of the link, if any, otherwise behaves the same as @code{url}. -@item nil -Show nothing. -@end table -@item w3-use-forms-index -@vindex w3-use-forms-index -@cindex ISINDEX handling -@cindex Forms based searching -@cindex Searching with forms -Non-@code{nil} means translate <ISINDEX> tags into a hypertext form. A -single text entry box is shown where the ISINDEX tag appears. -@item url-use-hypertext-gopher -@vindex url-use-hypertext-gopher -@cindex Gopher+ -Controls how gopher documents are retrieved. If non-@code{nil}, the -gopher pages are converted into HTML and parsed just like any other -page. If @code{nil}, the requests are passed off to the -@file{gopher.el} package by Scott Snyder. Using the @file{gopher.el} -package loses the gopher+ support, and inlined searching. -@item url-xterm-command -@vindex url-xterm-command -Command used to start a windowed shell, similar to an xterm. This -string is passed through @code{format}, and should expect four strings: -the title of the window, the program name to execute, and the server and -port number. The default is for xterm, which is very UNIX and -XWindows-centric. -@end table -@node Firewalls, Proxy Gateways, Basic Setup, Getting Started -@section Firewalls -@cindex Gateways -There are several different reasons why the gateway support might be -required. -@enumerate -@cindex Firewalls -@item -Stuck behind a firewall. This is usually the case at large corporations -with paranoid system-administrators. +@node Downloading, Building and Installing, Getting Started, Getting Started +@section Downloading +:: WORK :: What you need, and why +:: WORK :: Where to download Emacs, XEmacs, various platforms +:: WORK :: Where to download Emacs-W3 +:: WORK :: Where to download related utilities (netpbm, xv, gimp, etc.) -@cindex TERM -@item -Using TERM @footnote{TERM is a user-level protocol for emulating IP over -a serial line. More information is available at -ftp://sunsite.unc.edu/pub/Linux/apps/comm/term} for slip-like access to -the internet. +@node Building and Installing, Startup Files, Downloading, Getting Started +@section Building and Installing +:: WORK :: Document makefile variables +:: WORK :: Document what gets installed where, why -NOTE: XEmacs and Emacs 19.22 or later have patches to enable native TERM -networking. To enable it, #define TERM in the appropriate s/*.h file -for the operating system, then change the SYSTEM_LIBS define to include -the @file{termnet} library that comes with the latest versions of TERM. - -@item -@cindex Faulty hostname resolvers -@cindex Broken SUN libc -@cindex Can't resolve hostnames -Emacs cannot resolve hostnames. This happens quite often on Sun -workstations and some ULTRIX machines. Some C libraries do not include -the hostname resolver routines in their static libraries. If Emacs was -linked statically, this means it won't be able to get to any machines -off the local network. This is characterized by being able to reach -someplace with a raw ip number, but not its hostname -(http://129.79.254.191/ works, but http://www.cs.indiana.edu/ doesn't). - -If for some reason it is not feasible to recompile Emacs with the -@file{-lresolv} library or dynamic linking, it is just like being behind -a firewall. Another alternative is to set the variable -@code{url-broken-resolution} - this will use the support in ange-ftp or -EFS to use @file{nslookup} in a subprocess to do all hostname resolving. -See the variables @code{efs-nslookup-program}, -@code{efs-nslookup-on-connect}, and @code{efs-nslookup-threshold} if are -using EFS, or @code{ange-ftp-nslookup-program} if using Ange-FTP. +@node Startup Files, Preferences Panel, Building and Installing, Getting Started +@section Startup Files +@cindex Startup files +@cindex Default stylesheet +:: WORK :: startup files +This section should document where emacs-w3 looks for its startup files, +and what each one does. 'profile' 'stylesheet' 'hotlist' 'history' etc. -@end enumerate - -@vindex url-gateway-local-host-regexp -Emacs-W3 has support for using the gateway mechanism for certain -domains, and directly connecting to others. To use this, change the -value of @code{url-gateway-local-host-regexp}. This should be a regular -expression @footnote{Please see the full Emacs distribution for a -description of regular expressions} that matches local hosts that do not -require the use of a gateway. If @code{nil}, then all connections are -made through the gateway. - - -@vindex url-gateway-method -Emacs-W3 supports several methods of getting around gateways. The variable -@code{url-gateway-method} controls which of these methods is used. This -variable can have several values (use these as symbol names, not -strings): -@table @dfn -@item program -Run a program in a subprocess to connect to remote hosts (examples are -@i{itelnet}@footnote{Itelnet is a standard name for a telnet executable -that is capable of escaping the firewall. Check with system -administrators to see if anything similar is available}, an -@i{expect}@footnote{Expect is a scripting language that allows control -of interactive programs (like telnet) very easily. It is available from -gatekeeper.dec.com:/pub/GNU/expect-3.24.0.tar.gz} script, etc.). +@node Preferences Panel, , Startup Files, Getting Started +@section Preferences Panel +@cindex Preferences +@kindex M-x w3-preferences-edit +:: WORK :: pref panel +This should document the quick preferences panel. M-x w3-preferences-edit -@item tcp -Masanobu UMEDA (@i{umerin@@mse.kyutech.ac.jp}) has written a very nice -replacement for the standard networking in Emacs. This does basically -the same thing that a method of @code{program} does, but is slightly -more transparent to the user. -@item native -This means that Emacs-W3 should use the builtin networking code of Emacs. -This should be used only if there is no firewall, or the Emacs source -has already been hacked to get around the firewall. -@end table -One of these needs a bit more explanation than that: -@vindex url-gateway-telnet-ready-regexp -@vindex url-gateway-telnet-program -When running a program in a subprocess to emulate a network connection, -a few extra variables need to be set. The variable -@code{url-gateway-telnet-program} should point to an executable that -accepts a hostname and port # as its arguments, and passes standard -input to the remote host. This can be either the full path to the -executable or just the basename. The variable -@code{url-gateway-telnet-ready-regexp} controls how long Emacs-W3 should -wait after spawning the subprocess to start sending to its standard -input. This gets around a bug where telnet would miss the beginning of -requests becausse it did not buffer its input before opening a -connection. This should be a regular expression to watch for that -signifies the end of the setup of @code{url-gateway-telnet-program}. -The default should work fine for telnet. - -Emacs-W3 should now be able to get outside the local network. If none -of this makes sense, its probably my fault. Please check with the -network administrators to see if they have a program that does most of -this already, since somebody somewhere at the company has probably been -through something similar to this before, and would be much more -helpful/knowledgeable about the local setup than I would be. But feel -free to mail me as a last resort. +@node Basic Usage, Movement , Getting Started, Top +@chapter Basic Usage +@cindex Basic Usage +@kindex space +@kindex backspace +@kindex return +@kindex tab +@kindex M-tab +Emacs-W3 is similar to the Info package all Emacs users hold near and +dear to their hearts (@xref{Top,,Info,info, The Info Manual}, for a +description of Info). Basically, @kbd{space} and @kbd{backspace} +control scrolling, and @kbd{return} or the middle mouse button follows a +hypertext link. The @kbd{tab} and @kbd{Meta-tab} keys maneuver around the +various links on the page. -@node Proxy Gateways, Basic Usage, Firewalls, Getting Started -@section Proxy Gateways -@vindex url-proxy-services -@cindex Proxy Servers -@cindex Proxies -@cindex Proxies, environment variables -@cindex HTTP Proxy -In late January 1993, Kevin Altis and Lou Montulli proposed and -implemented a new proxy service. This service requires the use of -environment variables to specify a gateway server/port # to send -protocol requests to. Each protocol (HTTP, WAIS, gopher, FTP, etc.@:) -can have a different gateway server. The environment variables are -@var{PROTOCOL}_proxy, where @var{PROTOCOL} is one of the supported -network protocols (gopher, file, HTTP, FTP, etc.) - -@cindex No Proxy -@cindex Proxies, exclusion lists -@vindex NO_PROXY -For companies with internal intranets, it will usually be helpful to -define a list of hosts that should be contacted directly, @b{not} sent -through the proxy. The @var{NO_PROXY} environment variable controls -what hosts are able to be contacted directly. This should be a comma -separated list of hostnames, domain names, or a mixture of both. -Asterisks can be used as a wildcard. For example: - -@example -NO_PROXY=*.aventail.com,home.com,*.seanet.com -@end example - -tells Emacs-W3 to contact all machines in the @b{aventail.com} and -@b{seanet.com} domains directly, as well as the machine named -@b{home.com}. - -@vindex url-proxy-services -@cindex Proxies, setting from lisp -For those adventurous souls who enjoy writing regular expressions, all -the proxy settings can be manipulated from Emacs-Lisp. The variable -@code{url-proxy-services} controls this. This is an assoc list, keyed -on the protocol type (http, gopher, etc) in all lowercase. The -@code{cdr} of each entry should be the fully-specified URL of the proxy -server to contact, or, in the case of the special "no_proxy" entry, a -regular expression that matches any hostnames that should be contacted -directly. - -@example -(setq url-proxy-services '(("http" . "http://proxy.aventail.com/") - ("no_proxy" . "^.*\\(aventail\\|seanet\\)\.com"))) -@end example - -@node Basic Usage, , Proxy Gateways, Top -@chapter Basic Usage -Emacs-W3 is similar to the Info package all Emacs users hold near and dear to -their hearts (@xref{Top,,Info,info, The Info Manual}, for a description -of Info). Basically, @kbd{space} and @kbd{backspace} control scrolling, -and @kbd{return} or @kbd{mouse2} follows a hypertext link. The @kbd{f} -and @kbd{b} keys maneuver around the various links on the page. - -@b{NOTE:} To enter data into a form entry area, select it using -@kbd{return} or the middle mouse button, just like a hypertext link. +@b{NOTE:} Starting with Emacs-W3 3.0, form entry areas in a page can be +typed directly into. This is one of the main differences in navigation +from version 2.0. If you are used to using the @kbd{f} and @kbd{b} keys +to navigate around a buffer, I suggest training yourself to always use +@kbd{tab} and @kbd{M-tab} - it will save time and frustration on pages +with lots of form fields. By default, hypertext links are surrounded by '[[' and ']]' on non-graphic terminals (VT100, DOS window, etc.). On a graphics -terminal, the links are in shown in different colors. @xref{Controlling -Formatting} for information on how to change this, or for help on -getting the highlighting to work on graphics terminals. +terminal, the links are in shown in different colors. +@xref{Stylesheets} for information on how to change this. There are approximately 50 keys bound to special Emacs-W3 functions. The basic rule of thumb regarding keybindings in Emacs-W3 is that a @@ -624,26 +207,26 @@ @ifinfo @menu -* Movement:: Moving around in a Emacs-W3 buffer -* Information:: Getting information about the Emacs-W3 document being - viewed, and/or links within that document. -* Action:: Taking actions in a Emacs-W3 buffer (following links, - printing, etc.) -* Miscellaneous:: Miscellaneous keybindings +* Movement:: Moving around in the buffer. +* Information:: Getting information about a document. +* Action:: Following links, printing, etc. +* Miscellaneous:: Everything else. @end menu @end ifinfo @node Movement, Information, Basic Usage, Basic Usage @section Movement -:: WORK :: Document the 'h' and 'a' keymaps +All the standard Emacs bindings for movement are still in effect, with a +few additions for convenience. + @table @kbd -@findex scroll-up -@kindex SPC -@item SPC +@findex w3-scroll-up +@kindex space +@item space Scroll downward in the buffer. With prefix arg, scroll down that many screenfuls. -@kindex DEL +@kindex backspace @findex scroll-down -@item DEL +@item backspace Scroll upward in the buffer. With prefix arg, scroll up that many screenfuls. @kindex < @@ -655,96 +238,110 @@ @item > Goes to the end of document @kindex b -@kindex Shift-TAB -@findex w3-back-link -@item Shift-TAB, b +@kindex Meta-tab +@findex w3-widget-backward +@item Meta-tab, b Attempts to move backward one link area in the current document. Signals an error if no previous links are found. -@kindex hl -@findex w3-show-hotlist -@item hl -Displays a complete listing of the items in the hotlist. -@kindex hu -@findex w3-use-hotlist -@item hu -Go to a link in the hotlist. +@kindex f +@kindex tab +@kindex n +@findex w3-widget-forward +@item tab, f, n +Attempts to move forward one link area in the current document. Signals +an error if no more links are found. +@kindex B +@findex w3-backward-in-history +@item B +Move backwards in the history stack. +@kindex F +@findex w3-forward-in-history +@item F +Move forwards in the history stack. +@kindex l +@findex w3-goto-last-buffer +@item l +Return to the last buffer shown before this buffer. +@kindex q +@findex w3-quit +@item q +Kill this buffer. +@kindex Q, u +@findex w3-leave-buffer +Bury this buffer, but don't kill it +@end table + +@node Information, Action, Movement, Basic Usage +@section Information +These functions relate information about one or more links on the +current document. + +@table @kbd +@kindex v +@findex url-view-url +@item v +This shows the @sc{url} of the current document in the minibuffer. +@kindex V +@findex w3-view-this-url +@item V +This shows the @sc{url} of the hypertext link under point in the +minibuffer. +@kindex i +@findex w3-document-information +@item i +Shows miscellaneous information about the currently displayed document. +This includes the @sc{url}, the last modified date, @sc{mime} headers, +the @sc{http} response code, and any relationships to other documents. +Any security information is also displayed. +@kindex I +@findex w3-document-information-this-url +@item I +Shows information about the @sc{url} at point. +@kindex s +@findex w3-source-document +@item s +This shows the @sc{html} source of the current document in a separate buffer. +The buffer's name is based on the document's @sc{url}. +@kindex S +@findex w3-source-document-at-point +@item S +Shows the @sc{html} source of the hypertext link under point in a separate +buffer. The buffer's name is based on the document's @sc{url}. +@kindex k +@findex w3-save-url +@item k +This stores the current document's @sc{url} in the kill ring, and also in the +current window-system's clipboard, if possible. +@kindex K +@findex w3-save-this-url +@item K +Stores the @sc{url} of the document under point in the kill ring, and also in +the current window-system's clipboard, if possible. +@end table + +@node Action, Miscellaneous, Information, Basic Usage +@section Action +First, here are the keys and functions that bring up a new hypertext +page, usually creating a new buffer. +@table @kbd @kindex m @findex w3-complete-link @item m Choose a link from the current buffer and follow it. A completing-read is done on all the links, so @kbd{space} and @kbd{TAB} can be used for completion. -@kindex f -@kindex TAB -@kindex n -@findex w3-forward-link -@item TAB, f, n -Attempts to move forward one link area in the current document. Signals -an error if no more links are found. -@end table -@node Information, Action, Movement, Basic Usage -@section Information -These functions relate information about one or more links on the -current document. -@table @kbd -@kindex v -@findex url-view-url -@item v -This shows the URL of the current document in the minibuffer. -@kindex V -@findex w3-view-this-url -@item V -This shows the URL of the hypertext link under point in the minibuffer. -If there is not a hypertext link under point, then it shows the type of -form entry area under point. If there is no form entry area under -point, then it shows the inlined image's URL that is under point, if -any. -@kindex i -@findex w3-document-information -@item i -Shows miscellaneous information about the currently displayed document. -This includes the URL, the last modified date, MIME headers, the HTTP -response code, and any relationships to other documents. Any security -information is also displayed. -@kindex I -@findex w3-document-information-this-url -@item I -Shows information about the URL at point. -@kindex s -@findex w3-source-document -@item s -This shows the HTML source of the current document in a separate buffer. -The buffer's name is based on the document's URL. -@kindex S -@findex w3-source-document-at-point -@item S -Shows the HTML source of the hypertext link under point in a separate -buffer. The buffer's name is based on the document's URL. -@kindex k -@findex w3-save-url -@item k -This stores the current document's URL in the kill ring, and also in the -current window-system's clipboard, if possible. -@kindex K -@findex w3-save-this-url -@item K -Stores the URL of the document under point in the kill ring, and also in -the current window-system's clipboard, if possible. -@end table -@node Action, Miscellaneous, Information, Basic Usage -@section Action -First, here are the keys and functions that bring up a new hypertext -page, usually creating a new buffer. -@table @kbd @kindex return @findex w3-follow-link @item return Pressing return when over a hyperlink attempts to follow the link under the cursor. With a prefix argument (@kbd{C-u}), this forces the file to be saved to disk instead of being passed off to other viewers -or being parsed as HTML. +or being parsed as @sc{html}. -Pressing return when over a form input field will prompt in the +Pressing return when over a form input field can cause auto-submission +of the form. This is for Mosaic and Netscape compatibility. If there +is only one item in the form other than submit or reset buttons, then + minibuffer for the data to insert into the input field. Type checking is done, and the data is only entered into the form when data of the correct type is entered (ie: cannot enter 44 for 'date' field, etc). @@ -771,12 +368,12 @@ @findex w3-print-this-url @item p Prints out the current buffer in a variety of formats, including -PostScript, HTML source, or formatted text. +PostScript, @sc{html} source, or formatted text. @kindex P @findex w3-print-url-under-point @item P -Prints out the URL under point in a variety of formats, including -PostScript, HTML source, or formatted text. +Prints out the @sc{url} under point in a variety of formats, including +PostScript, @sc{html} source, or formatted text. @kindex m @findex w3-complete-link @item m @@ -795,7 +392,7 @@ @kindex C-o @findex w3-fetch @item C-o -Prompts for a URL in the minibuffer, and attempts to fetch +Prompts for a @sc{url} in the minibuffer, and attempts to fetch it. If there are any errors, or Emacs-W3 cannot understand the type of link requested, the errors are displayed in a hypertext buffer. @kindex o @@ -816,13 +413,13 @@ Perform a search, if this is a searchable index. Searching requires a server - Emacs-W3 can not do local file searching, as there are too many possible types of searches people could want to do. Generally, the only -URL types that allow searching are HTTP, gopher, and X-EXEC. +@sc{url} types that allow searching are @sc{http}, gopher, and X-EXEC. @kindex Hv @findex w3-show-history-list @vindex w3-keep-history @item Hv If @code{url-keep-history} is non-@code{nil}, then Emacs-W3 keeps track -of all the URLs visited in an Emacs session. This function takes all +of all the @sc{url}s visited in an Emacs session. This function takes all the links that are in that internal list, and formats them as hypertext links in a list. @end table @@ -863,23 +460,23 @@ effect if at the end of the session history. @end table -@node Miscellaneous, , Action, Basic Usage +@node Miscellaneous, Compatibility, Action, Basic Usage @section Miscellaneous @table @kbd @kindex M-m @findex w3-mail-current-document @item M-m Mails the current document to someone. Choose from several different -formats to mail: formatted text, HTML source, PostScript, or LaTeX source. -When the HTML source is mailed, then an appropriate <base> tag is inserted +formats to mail: formatted text, @sc{html} source, PostScript, or LaTeX source. +When the @sc{html} source is mailed, then an appropriate <base> tag is inserted at the beginning of the document so that relative links may be followed correctly by whoever receives the mail. @kindex M-M @findex w3-mail-document-under-point @item M-M Mails the document pointed to by the hypertext link under point to someone. -Choose from several different formats to mail: formatted text, HTML source, -PostScript, or LaTeX source. When the HTML source is mailed, then an +Choose from several different formats to mail: formatted text, @sc{html} source, +PostScript, or LaTeX source. When the @sc{html} source is mailed, then an appropriate <base> tag is inserted at the beginning of the document so that relative links may be followed correctly by whoever receives the mail. @@ -887,7 +484,7 @@ @findex w3-print-this-url @item p Prints the current document. Choose from several different formats to -print: formatted text, HTML source, PostScript (with ps-print), or by using +print: formatted text, @sc{html} source, PostScript (with ps-print), or by using LaTeX and dvips). @findex lpr-buffer @@ -897,11 +494,11 @@ is called, and the variables @code{lpr-command} and @code{lpr-switches} control how the document is printed. -When the HTML source is printed, then an appropriate <base> tag is +When the @sc{html} source is printed, then an appropriate <base> tag is inserted at the beginning of the document. @vindex w3-print-commnad @vindex w3-latex-docstyle -When postscript is printed, then the HTML source of the document is +When postscript is printed, then the @sc{html} source of the document is converted into LaTeX source. There are several variables controlling what the final LaTeX document looks like. @@ -915,7 +512,7 @@ will be used instead. @item w3-latex-docstyle @vindex w3-latex-docstyle -The document style to use when printing or mailing converted HTML files +The document style to use when printing or mailing converted @sc{html} files in LaTeX. Good defaults are: @{article@}, [psfig,twocolumn]@{article@}, etc. @item w3-latex-packages @@ -928,8 +525,8 @@ document titles. @item w3-latex-print-links @vindex w3-latex-print-links -If non-@code{nil}, prints the URLs of hypertext links as endnotes at the -end of the document. If set to @code{footnote}, prints the URL's as +If non-@code{nil}, prints the @sc{url}s of hypertext links as endnotes at the +end of the document. If set to @code{footnote}, prints the @sc{url}'s as footnotes on each page. @end table @@ -941,15 +538,15 @@ @kindex M-x w3-insert-formatted-url @findex w3-insert-formatted-url @item M-x w3-insert-formatted-url -Insert a fully formatted HTML link into another buffer. This gets the -name and URL of either the current buffer, or, with a prefix arg, of the +Insert a fully formatted @sc{html} link into another buffer. This gets the +name and @sc{url} of either the current buffer, or, with a prefix arg, of the link under point, and construct the appropriate <a...>...</a> markup and insert it into the desired buffer. @kindex M-tab @findex w3-insert-this-url @item M-tab -Inserts the URL of the current document into another buffer. Buffer is -prompted for in the minibuffer. With prefix arg, uses the URL of the +Inserts the @sc{url} of the current document into another buffer. Buffer is +prompted for in the minibuffer. With prefix arg, uses the @sc{url} of the link under point. @kindex U @findex w3-use-links @@ -966,7 +563,7 @@ relationship. @end table -@node Compatibility, , , Top +@node Compatibility, Emulation, Miscellaneous, Top @chapter Compatibility with other Browsers Due to the popularity of several other browsers, Emacs-W3 offers an easy transition to its much better way of life. This ranges from being able @@ -985,9 +582,6 @@ 'forward' and 'back' buttons easily. * Global History:: Keeping a history of all the places ever visited on the web. -* Annotations:: Annotations allow comments on other - people's Web documents without needing - to change the document. @end menu @end ifinfo @node Emulation, Hotlist Handling, Compatibility, Compatibility @@ -1002,7 +596,131 @@ @findex w3-lynx-emulation-minor-mode @vindex w3-mode-hook :: WORK :: Document lynx emulation +@table @key +@item Down arrow +Highlight next topic +@item Up arrow +Highlight previous topic +@item Right arrow, Return, Enter +Jump to highlighted topic +@item Left arrow +Return to previous topic +@item + +Scroll down to next page (Page-Down) +@item - +Scroll up to previous page (Page-Up) +@item SPACE +Scroll down to next page (Page-Down) +@item b +Scroll up to previous page (Page-Up) +@item C-A +Go to first page of the current document (Home) +@item C-E +Go to last page of the current document (End) +@item C-B +Scroll up to previous page (Page-Up) +@item C-F +Scroll down to next page (Page-Down) +@item C-N +Go forward two lines in the current document +@item C-P +Go back two lines in the current document +@item ) +Go forward half a page in the current document +@item ( +Go back half a page in the current document +@item # +Go to Toolbar or Banner in the current document +@item ?, h +Help (this screen) +@item a +Add the current link to a bookmark file +@item c +Send a comment to the document owner +@item d +Download the current link +@item e +Edit the current file +@item g +Goto a user specified @sc{url} or file +@item i +Show an index of documents +@item j +Execute a jump operation +@item k +Show a list of key mappings +@item l +List references (links) in current document +@item m +Return to main screen +@item o +Set your options +@item p +Print the current document +@item q +Quit +@item / +Search for a string within the current document +@item s +Enter a search string for an external search +@item n +Go to the next search string +@item v +View a bookmark file +@item V +Go to the Visited Links Page +@item x +Force submission of form or link with no-cache +@item z +Cancel transfer in progress +@item [backspace] +Go to the history Page +@item = +Show file and link info +@item \ +Toggle document source/rendered view +@item ! +Spawn your default shell +@item * +Toggle image_links mode on and off +@item [ +Toggle pseudo_inlines mode on and off +@item ] +Send an @sc{http} @sc{head} request for the current doc or link +@item C-R +Reload current file and refresh the screen +@item C-W +Refresh the screen +@item C-U +Erase input line +@item C-G +Cancel input or transfer +@item C-T +Toggle trace mode on and off +@item C-K +Invoke the Cookie Jar Page +@end table + :: WORK :: Document netscape emulation +Uh, turn this into pretty tables about what keys are emulated. + +@example +(define-key w3-netscape-emulation-minor-mode-map "\M-s" 'w3-save-as) +(define-key w3-netscape-emulation-minor-mode-map "\M-m" 'w3-mailto) +(define-key w3-netscape-emulation-minor-mode-map "\M-n" 'make-frame) +(define-key w3-netscape-emulation-minor-mode-map "\M-l" 'w3-fetch) +(define-key w3-netscape-emulation-minor-mode-map "\M-o" 'w3-open-local) +(define-key w3-netscape-emulation-minor-mode-map "\M-p" 'w3-print-this-url) +(define-key w3-netscape-emulation-minor-mode-map "\M-q" 'w3-quit) +(define-key w3-netscape-emulation-minor-mode-map "\M-f" 'w3-search-forward) +(define-key w3-netscape-emulation-minor-mode-map "\M-g" 'w3-search-again) +(define-key w3-netscape-emulation-minor-mode-map "\M-r" 'w3-reload-document) +(define-key w3-netscape-emulation-minor-mode-map "\M-i" 'w3-load-delayed-images) +(define-key w3-netscape-emulation-minor-mode-map "\M-a" 'w3-hotlist-add-document) +(define-key w3-netscape-emulation-minor-mode-map "\M-b" 'w3-show-hotlist) +(define-key w3-netscape-emulation-minor-mode-map "\M-h" 'w3-show-history-list) + +@end example @node Hotlist Handling, Session History, Emulation, Compatibility @section Hotlist Handling @@ -1010,7 +728,7 @@ :: WORK :: Make sure everything hotlist related can be accessed via 'h' In order to avoid having to traverse many documents to get to the same document over and over, Emacs-W3 supports a ``hotlist'' like Mosaic. This is -a file that contains URLs and aliases. Hotlists allow quick access to any +a file that contains @sc{url}s and aliases. Hotlists allow quick access to any document in the Web, providing it has been visited and added to the hotlist. The variable @code{w3-hotlist-file} determines where this information is saved. The structure of the file is compatible with Mosaic's @@ -1024,9 +742,8 @@ @item a Adds the current document to the hotlist, with the buffer name as its identifier. Modifies the file specified by @code{w3-hotlist-file}. If -this is given a @var{prefix-argument} (via @kbd{C-u}), the title is -prompted for instead of automatically defaulting to the -document title. +this is given a prefix-argument (via @kbd{C-u}), the title is prompted +for instead of automatically defaulting to the document title. @findex w3-hotlist-refresh @vindex w3-hotlist-file @@ -1062,7 +779,7 @@ @item hv @kindex hv @findex w3-show-hotlist -Converts the hotlist into HTML and displays it. +Converts the hotlist into @sc{html} and displays it. @item ha @kindex ha @findex w3-hotlist-apropos @@ -1075,16 +792,16 @@ @node Session History, Global History, Hotlist Handling, Compatibility @section History @cindex History Lists -Almost all web browsers keep track of the URLs followed from a page, so +Almost all web browsers keep track of the @sc{url}s followed from a page, so that it can provide @b{forward} and @b{back} buttons to keep a @i{path} -of URLs that can be traversed easily. +of @sc{url}s that can be traversed easily. @vindex url-keep-history If the variable @code{url-keep-history} is @code{t}, then Emacs-W3 -keeps a list of all the URLs visited in a session. +keeps a list of all the @sc{url}s visited in a session. @findex w3-show-history To view a listing of the history for this session of Emacs-W3, use @code{M-x w3-show-history} from any buffer, and Emacs-W3 generates an -HTML document showing every URL visited since Emacs started (or +@sc{html} document showing every @sc{url} visited since Emacs started (or cleared the history list), and then format it. Any of the links can be chosen and followed to the original document. To clear the history list, choose 'Clear History' from the 'Options' menu. @@ -1093,29 +810,29 @@ @findex w3-backward-in-history @findex w3-fetch Another twist on the history list mechanism is the fact that all -Emacs-W3 buffers remember what URL, buffer, and buffer position of the +Emacs-W3 buffers remember what @sc{url}, buffer, and buffer position of the last document, and also keeps track of the next location jumped @b{to} from that buffer. This means that the user can go forwards and backwards very easily along the path taken to reach a particular document. To go forward, use the function @code{w3-forward-in-history}, to go backward, use the function @code{w3-backward-in-history}. -@node Global History, Annotations, Session History, Compatibility +@node Global History, Stylesheets, Session History, Compatibility @section Global History :: WORK :: Document that the global history can have diff. formats -Most web browsers also support the idea of a ``history'' of URLs the +Most web browsers also support the idea of a ``history'' of @sc{url}s the user has visited, and it displays them in a different style than normal -URLs. +@sc{url}s. @vindex url-keep-history @vindex url-global-history-file If the variable @code{url-keep-history} is @code{t}, then Emacs-W3 -keeps a list of all the URLs visited in a session. The file is +keeps a list of all the @sc{url}s visited in a session. The file is automatically written to disk when exiting emacs. The list is added to those already in the file specified by @code{url-global-history-file}, which defaults to @file{~/.mosaic-global-history}. -If any URL in the list is found in the file, it is not saved, but new +If any @sc{url} in the list is found in the file, it is not saved, but new ones are added at the end of the file. The function that saves the global history list is smart enough to @@ -1127,355 +844,942 @@ One of the nice things about keeping a global history files is that Emacs-W3 can use it as a completion table. When doing @kbd{M-x w3-fetch}, pressing the @kbd{tab} or @kbd{space} key will show all completions for a -partial URL. This is very useful, especially for very long URLs that +partial @sc{url}. This is very useful, especially for very long @sc{url}s that are not in a hotlist, or for seeing all the pages from a particular web site before choosing which to retrieve. -@node Annotations, Group Annotations, Global History, Compatibility -@section Annotations -@cindex Annotations -Mosaic can @i{annotate} documents. Annotations are comments about the -current document, and these annotations appear as a link to the comments -at the end of the document. The original file is not changed. - -@ifinfo -@menu -* Group Annotations:: Annotations accessible by everyone -* Personal Annotations:: Private annotations only accessible - to the user who created them -@end menu -@end ifinfo -@node Group Annotations, Personal Annotations, Annotations, Annotations -@subsection Group Annotations -@cindex Group Annotations -@b{@i{NOTE}}: The group annotation experiment has been terminated. It -will be replaced with support on the server side for adding <LINK> tags -to documents. - -@node Personal Annotations, , Group Annotations, Annotations -@subsection Personal Annotations -@cindex Personal Annotations -@vindex w3-personal-annotation-directory -Emacs-W3 looks in the directory specified by -@code{w3-personal-annotation-directory} (defaults to -@file{~/.mosaic-personal-annotations}). Any personal annotations for a -document are automatically appended when it is retrieved. +@node Stylesheets, Terminology, Global History, Top +@chapter Stylesheets +The way in which Emacs-W3 formats a document is very customizable. All +formatting is now controlled by a default stylesheet set by the user +with the @code{w3-default-stylesheet} variable. Emacs-W3 currently +supports the @sc{W3C} recommendation for Cascading Style Sheets, Level 1 +(commonly known as @sc{CSS1}) with a few experimental items from other +W3C proposals. Wherever Emacs-W3 diverges from the specification, it +will be clearly documented, and will be changed once a full standard is +available. -:: WORK :: Document the new 'a' prefix keymap -:: WORK :: Tell where the annotations are stored - -@findex w3-add-personal-annotation -@vindex w3-annotation-mode -To add a new personal annotation, type @kbd{M-x -w3-add-personal-annotation}. This creates a new buffer, in the mode -specified by @code{w3-annotation-mode}. This defaults to -@code{html-mode}. If this variable is @code{nil}, or it points to an -undefined function, then @code{default-major-mode} is consulted. - -A minor mode redefines @kbd{C-c C-c} to complete the annotation and -store it on the local disk. +Support for @sc{DSSSL} is progressing, but spare time is at an all-time +low. If anyone would like to help, please contact the author. -@findex w3-delete-personal-annotation -To delete a personal annotation, it must be the current page. Once -reading the annotation, @kbd{M-x w3-delete-personal-annotation} will -remove it. This deletes the file containing the annotation, and any -references to it in the annotation log file. - -Editing personal annotations is not yet supported. - -@node Controlling Formatting, General Formatting, Top, Top -@chapter Controlling Formatting -@cindex Customizing formatting -@cindex Specifying Fonts -@cindex Fonts -@cindex Colors -How Emacs-W3 formats a document is very customizable. All control over -formatting is now controlled by a default stylesheet set by the user -with the @code{w3-default-sheet} variable. - -The following sections describe in more detail how to change the -formatting of a document. +The following sections closely parallel the @sc{CSS1} specification so +it should be very easy to look up what Emacs-W3 supports when browsing +through the @sc{CSS1} specification. Please note that a lot of the text +in the following sections comes directly from the specification as +well. @ifinfo @menu -* General Formatting:: Changing general things about a - document. -* Character based terminals:: Changing how a document is - displayed on a non-graphics - terminal (vt100, etc.@:) or if - @code{w3-delimit-emphasis} is @code{t}. -* Graphics workstations:: Changing how a document is - displayed on a graphics terminal - (Xwindows, Windows, NeXTstep, - OS/2, etc.) -* Inlined images:: How to specify how Emacs-W3 - handles inlined images/mpegs. +* Terminology:: Terms used in the rest of this chapter. +* Basic Concepts:: Why are stylesheets useful? Getting started. +* Pseudo-Classes/Elements:: Special classes for elements. +* The Cascade:: How stylesheets are combined. +* Properties:: What properties you can set on elements. +* Units:: What you can set them to. @end menu @end ifinfo -@node General Formatting, Character based terminals, Controlling Formatting, Controlling Formatting -@section General formatting conventions -@iftex -@heading Setting the fill column -@end iftex -@ifinfo -@center -------------------- -@center Setting the right margin -@center -------------------- -@end ifinfo -@cindex Margins -@vindex fill-column -@vindex w3-right-border -Each time a document is parsed, the right margin is recalculated -using the width of the current window and @code{w3-right-border}. -@code{w3-right-border} is an integer specifying how much room at the -right edge of the screen to leave blank. The @code{fill-column} is set -to @code{(- (window-width) @code{w3-right-border})}. -@iftex -@heading Formatting of directory listings -@end iftex -@ifinfo -@center -------------------- -@center Formatting of directory listings -@center -------------------- -@end ifinfo -@vindex url-use-hypertext-dired -When Emacs-W3 encounters a link to a directory (whether by local file access -or via FTP), it can either create an HTML document on the fly, or use -@code{dired-mode} to peruse the listing. The variable -@code{url-use-hypertext-dired} controls this behavior. + +@node Terminology, Basic Concepts, Stylesheets, Stylesheets +@section Terminology -If the value is @code{t}, Emacs-W3 uses @code{directory-files} to list them -out and transform the directory into a hypertext document, then pass it -through the parser like any other document. - -If the value is @code{nil}, just pass the directory off to dired using -@code{find-file}. Using this option loses all the hypertext abilities -of Emacs-W3, and the users is unable to load documents in the directory -directly into Emacs-W3 by clicking with the mouse, etc. +@table @dfn +@item attribute +HTML attribute, ie: @samp{align=center} - align is the attribute. +@item author +The author of an HTML document. +@item block-level element +An element which has a line break before and after (e.g. 'H1' in @sc{HTML}). +@item canvas +The part of the UA's drawing surface onto which documents are rendered. +@item child element +A subelement in @sc{sgml} terminology. +@item contextual selector +A selector that matches elements based on their position in the document +structure. A contextual selector consists of several simple +selectors. E.g., the contextual selector 'H1.initial B' consists of two +simple selectors, 'H1.initial' and 'B'. +@item @sc{css} +Cascading Style Sheets. +@item declaration +A property (e.g. 'font-size') and a corresponding value (e.g. '12pt'). +@item designer +The designer of a style sheet. +@item document +@sc{html} document. +@item element +@sc{html} element. +@item element type +A generic identifier in @sc{sgml} terminology. +@item fictional tag sequence +A tool for describing the behavior of pseudo-classes and pseudo-elements. +@item font size +The size for which a font is designed. Typically, the size of a font is +approximately equal to the distance from the bottom of the lowest letter +with a descender to the top of the tallest letter with an ascender and +(optionally) with a diacritical mark. +@item @sc{html} extension +Markup introduced by UA vendors, most often to support certain visual +effects. The @sc{font}, @sc{center} and @sc{blink} elements are examples +of HTML extensions, as is the @sc{bgcolor} attribute. One of the goals +of @sc{css} is to provide an alternative to @sc{html} extensions. +@item inline element +An element which does not have a line break before and after +(e.g. '@sc{strong}' in @sc{html}) +@item intrinsic dimensions +The width and height as defined by the element itself, not imposed by +the surroundings. In this specification it is assumed that all replaced +elements -- and only replaced elements -- come with intrinsic +dimensions. +@item parent element +The containing element in @sc{sgml} terminology. +@item pseudo-element +Pseudo-elements are used in @sc{css} selectors to address typographical +items (e.g. the first line of an element) rather than structural +elements. +@item pseudo-class +Pseudo-classes are used in @sc{css} selectors to allow information +external to the @sc{html} source (e.g. the fact that an anchor has been +visited or not) to classify elements. +@item property +A stylistic parameter that can be influenced through @sc{css}. +@item reader +The person for whom the document is rendered. +@item replaced element +An element that the @sc{css} formatter only knows the intrinsic +dimensions of. In @sc{html}, @sc{img}, @sc{input}, @sc{textarea}, +@sc{select} and @sc{object} elements can be examples of replaced +elements. E.g., the content of the @sc{img} element is often replaced by +the image that the @sc{src} attribute points to. @sc{css1} does not +define how the intrinsic dimensions are found. +@item rule +A declaration (e.g. 'font-family: helvetica') and its selector +(e.g. @sc{'H1'}). +@item selector +A string that identifies what elements the corresponding rule applies +to. A selector can either be a simple selector (e.g. 'H1') or a +contextual selector (e.g. @sc{'h1 b'}) which consists of several simple +selectors. +@item @sc{sgml} +Standard Generalized Markup Language, of which @sc{html} is an +application. +@item simple selector +A selector that matches elements based on the element type and/or +attributes, and not he element's position in the document +structure. E.g., 'H1.initial' is a simple selector. +@item style sheet +A collection of rules. +@item @sc{ua} +User Agent, often a web browser or web client. +@item user +Synonymous with reader. +@item weight +The priority of a rule. +@end table -@iftex -@heading Formatting of gopher directories -@end iftex -@ifinfo -@center -------------------- -@center Formatting of gopher directories -@center -------------------- -@end ifinfo -@vindex w3-use-hypertext-gopher -@cindex Gopher+ -@cindex ASK blocks -There are two different ways of viewing gopher links. The built-in -support that converts gopher directories into HTML, or the -@file{gopher.el} package by Scott Snyder (@i{snyder@@fnald0.fnal.gov}). -The variable that controls this is @code{w3-use-hypertext-gopher}. If -set to @code{nil}, then @file{gopher.el} is used. Any other value -causes Emacs-W3 to use its internal gopher support. If using -@file{gopher.el}, all the hypertext capabilities of Emacs-W3 are lost. -All the functionality of @file{gopher.el} is now available in the -hypertext version, and the hypertext version supports Gopher+ and ASK -blocks. +@node Basic Concepts, Pseudo-Classes/Elements, Terminology, Stylesheets +@section Basic Concepts +Designing simple style sheets is easy. One needs only to know a little +HTML and some basic desktop publishing terminology. E.g., to set the +text color of 'H1' elements to blue, one can say: + +@example + H1 @{ color: blue @} +@end example + +The example above is a simple CSS rule. A rule consists of two main +parts: selector ('H1') and declaration ('color: blue'). The declaration +has two parts: property ('color') and value ('blue'). While the example +above tries to influence only one of the properties needed for rendering +an HTML document, it qualifies as a style sheet on its own. Combined +with other style sheets (one fundamental feature of CSS is that style +sheets are combined) it will determine the final presentation of the +document. + +The selector is the link between the HTML document and the style sheet, and +all HTML element types are possible selectors. + +@node Pseudo-Classes/Elements, The Cascade, Basic Concepts, Stylesheets +@section Pseudo-Classes/Elements +In @sc{css1}, style is normally attached to an element based on its +position in the document structure. This simple model is sufficient for +a wide variety of styles, but doesn't cover some common effects. The +concept of pseudo-classes and pseudo-elements extend addressing in +@sc{css1} to allow external information to influence the formatting +process. -@vindex w3-gopher-labels -The main way to control the display of gopher directories is by the -variable @code{w3-gopher-labels}. This variable controls the text that -is inserted at the front of each item. This is an assoc list of gopher -types (as one character strings), and a string to insert just after the -list item. All the normal gopher types are defined. Entries should be -similar to: @samp{("0" . "(TXT)")}. I have tried to keep all the tags -to three characters plus two parentheses. -@iftex -@heading Creating a horizontal rule -@end iftex -@ifinfo -@center -------------------- -@center Creating a horizontal rule -@center -------------------- -@end ifinfo -@vindex w3-horizontal-rule-char -Horizontal rules (@b{<HR>} tags in HTML[+]) are used to separate chunks -of a document, and is meant to be rendered as a solid line across the -page. Some terminals display characters differently, so the variable -@code{w3-horizontal-rule-char} controls which character is used to draw -a horizontal bar. This variable must be the ASCII value of the -character, @b{not a string}. The variable is passed through -@code{make-string} whenever a horizontal rule of a certain width is -necessary. +Pseudo-classes and pseudo-elements can be used in @sc{css} selectors, +but do not exist in the @sc{html} source. Rather, they are "inserted" by +the @sc{ua} under certain conditions to be used for addressing in style +sheets. They are referred to as "classes" and "elements" since this is a +convenient way of describing their behavior. More specifically, their +behavior is defined by a fictional tag sequence. + +Pseudo-elements are used to address sub-parts of elements, while +pseudo-classes allow style sheets to differentiate between different +element types. + +The only support pseudo-classes in Emacs-W3 are on the anchor tag +(<a>...</a>). + +User agents commonly display newly visited anchors differently from +older ones. In @sc{css1}, this is handled through pseudo-classes on the +'A' element: + +@example + A:link @{ color: red @} /* unvisited link */ + A:visited @{ color: blue @} /* visited links */ + A:active @{ color: lime @} /* active links */ +@end example + +All 'A' elements with an 'HREF' attribute will be put into one and only +one of these groups (i.e. target anchors are not affected). UAs may +choose to move an element from 'visited' to 'link' after a certain +time. An 'active' link is one that is currently being selected (e.g. by +a mouse button press) by the reader. -@node Character based terminals, Graphics workstations, General Formatting, Controlling Formatting -@section On character based terminals -@vindex w3-delimit-emphasis -On character based terminals, there is no easy way to show that a -certain range of text is in bold or italics. If the variable -@code{w3-delimit-emphasis} is non-@code{nil}, then Emacs-W3 can insert -characters before and after character formatting commands in HTML -documents. The defaul value of @code{w3-delimit-emphasis} is -automatically set based on the type of window system and version of -Emacs being used. +The formatting of an anchor pseudo-class is as if the class had been +inserted manually. A @sc{ua} is not required to reformat a currently +displayed document due to anchor pseudo-class transitions. E.g., a style +sheet can legally specify that the 'font-size' of an 'active' link +should be larger that a 'visited' link, but the UA is not required to +dynamically reformat the document when the reader selects the 'visited' +link. + +Pseudo-class selectors do not match normal classes, and vice versa. The +style rule in the example below will therefore not have any influence: + +@example + A:link @{ color: red @} + + <A CLASS=link NAME=target5> ... </A> +@end example -@vindex w3-header-chars-assoc -:: WORK :: +In @sc{css1}, anchor pseudo-classes have no effect on elements other +than 'A'. Therefore, the element type can be omitted from the selector: + +@example + A:link @{ color: red @} + :link @{ color: red @} +@end example + +The two selectors above will select the same elements in CSS1. + +Pseudo-class names are case-insensitive. + +Pseudo-classes can be used in contextual selectors: + +@example + A:link IMG @{ border: solid blue @} +@end example -@findex w3-upcase-region -@code{w3-header-chars-assoc} is an assoc list of header tags and a list -of formatting instructions. The @code{car} of the list is the level of -the header (1--6). The rest of the list should contain three items. -The first item is text to insert before the header. The second item is -text to insert after the header. Both should have reserved characters -converted to their HTML[+] entity definitions. The third item is a -function to call on the area the header is in. This function is called -with arguments specifying the start and ending character positions of -the header. The starting point is always first. To convert a region to -upper case, please use @code{w3-upcase-region} instead of -@code{upcase-region}, so that entities are converted properly. +Also, pseudo-classes can be combined with normal classes: + +@example + A.external:visited @{ color: blue @} + + <A CLASS=external HREF="http://out.side/">external link</A> +@end example + +If the link in the above example has been visited, it will be rendered +in blue. Note that normal class names precede pseudo-classes in the +selector. -@node Graphics workstations, Inlined images, Character based terminals, Controlling Formatting -@section With graphics workstations -Starting with the first public release of version 2.3.0, all formatting -is controlled by the use of stylesheets. +@node The Cascade, Properties, Pseudo-Classes/Elements, Stylesheets +@section The Cascade + +In @sc{css}, more than one style sheet can influence the presentation +simultaneously. There are two main reasons for this feature: modularity +and author/reader balance. -:: WORK :: Graphic workstation stuff - redo for stylesheets +@table @i +@item modularity +A style sheet designer can combine several (partial) style sheets to +reduce redundancy: + +@example + @@import url(http://www.style.org/pastoral); + @@import url(http://www.style.org/marine); -@node Inlined images, , Graphics workstations, Controlling Formatting -@cindex Inlined images -@cindex Images -@cindex Movies -@cindex Inlined MPEGs -@cindex MPEGs -When running in Lucid Emacs 19.10 or XEmacs 19.11 and higher, Emacs-W3 can -display inlined images and MPEG movies. There are several variables that -control how and when the images are displayed. + H1 @{ color: red @} /* override imported sheets */ +@end example +@item author/reader balance +Both readers and authors can influence the presentation through style +sheets. To do so, they use the same style sheet language thus reflecting +a fundamental feature of the web: everyone can become a publisher. The +@sc{ua} is free to choose the mechanism for referencing personal style +sheets. +@end table + +Sometimes conflicts will arise between the style sheets that influence +the presentation. Conflict resolution is based on each style rule having +a weight. By default, the weights of the reader's rules are less than +the weights of rules in the author's documents. I.e., if there are +conflicts between the style sheets of an incoming document and the +reader's personal sheets, the author's rules will be used. Both reader +and author rules override the @sc{ua}'s default values. -@cindex Netpbm -@cindex Pbmplus -@vindex w3-graphic-converter-alist -Since Lucid/XEmacs only natively understands XPixmaps and XBitmaps, GIFs -and other image types must first be converted to one of these formats. -To do this, the @b{netpbm utilities}@footnote{Available via anonymous -ftp from ftp.x.org:/R5contrib/netpbm-1mar1994.tar.gz, and most large ftp -sites.} programs are normally used. This is a suite of freeware image -conversion tools. The variable @code{w3-graphic-converter-alist} -controls how each image type is converted. This is an assoc list, keyed -on the MIME content-type. The @code{car} is the content-type, and the -@code{cdr} is a string suitable to pass to @code{format}. A %s in this -string will be replaced with a converter from the ppm image format to an -XPixmap (or XBitmap, if being run on a monochrome display). By default, -the Emacs-W3 browser has converters for: +The imported style sheets also cascade with each other, in the order +they are imported, according to the cascading rules defined below. Any +rules specified in the style sheet itself override rules in imported +style sheets. That is, imported style sheets are lower in the cascading +order than rules in the style sheet itself. Imported style sheets can +themselves import and override other style sheets, recursively. + +In @sc{css1}, all '@@import' statements must occur at the start of a +style sheet, before any declarations. This makes it easy to see that +rules in the style sheet itself override rules in the imported style +sheets. + +NOTE: The use of !important in @sc{css} stylesheets is unsupported at +this time. + +Conflicting rules are intrinsic to the CSS mechanism. To find the value +for an element/property combination, the following algorithm must be +followed: @enumerate @item -image/x-xbitmap -@item -image/xbitmap -@item -image/xbm -@item -image/gif +Find all declarations that apply to the element/property in +question. Declarations apply if the selector matches the element in +question. If no declarations apply, the inherited value is used. If +there is no inherited value (this is the case for the 'HTML' element and +for properties that do not inherit), the initial value is used. +@item +Sort the declarations by explicit weight: declarations marked +'!important' carry more weight than unmarked (normal) declarations. @item -image/jpeg -@item -image/x-fax -@item -image/x-raster -@item -image/windowdump +Sort by origin: the author's style sheets override the reader's style +sheet which override the UA's default values. An imported style sheet +has the same origin as the style sheet from which it is imported. @item -image/x-icon -@item -image/portable-graymap -@item -image/portable-pixmap -@item -image/x-pixmap +Sort by specificity of selector: more specific selectors will override +more general ones. To find the specificity, count the number of ID +attributes in the selector (a), the number of CLASS attributes in the +selector (b), and the number of tag names in the selector +(c). Concatenating the three numbers (in a number system with a large +base) gives the specificity. Some examples: +@example + LI @{...@} /* a=0 b=0 c=1 -> specificity = 1 */ + UL LI @{...@} /* a=0 b=0 c=2 -> specificity = 2 */ + UL OL LI @{...@} /* a=0 b=0 c=3 -> specificity = 3 */ + LI.red @{...@} /* a=0 b=1 c=1 -> specificity = 11 */ + UL OL LI.red @{...@} /* a=0 b=1 c=3 -> specificity = 13 */ + #x34y @{...@} /* a=1 b=0 c=0 -> specificity = 100 */ +@end example +Pseudo-elements and pseudo-classes are counted as normal elements and +classes, respectively. @item -image/x-xpixmap -@item -image/pict -@item -image/x-macpaint -@item -image/x-targa -@item -image/tiff +Sort by order specified: if two rules have the same weight, the latter +specified wins. Rules in imported style sheets are considered to be +before any rules in the style sheet itself. @end enumerate -@vindex w3-color-max-blue -@vindex w3-color-max-green -@vindex w3-color-max-red -@vindex w3-color-use-reducing -@vindex w3-color-filter -Since most displays are (sadly) not 24-bit, Emacs-W3 can automatically -dither an image, so that it does not fill up the application' colormap too -quickly. If @code{w3-color-use-reducing} is non-@code{nil}, then the -images will use reduced colors. If @code{w3-color-filter} is @code{eq} to -@code{'ppmquant}, then the ppmquant program will be used. If @code{eq} to -@code{'ppmdither}, then the ppmdither program will be used. The ppmdither -program tends to give better results. The values of -@code{w3-color-max-red}, @code{w3-color-max-blue}, and -@code{w3-color-max-green} control how many colors the inlined images can -use. If using ppmquant, then the product of these three variables is used -as the maximum number of colors per image. If using ppmdither, then only -the set number of color cells can be allocated per image. See the man -pages for ppmdither and ppmquant for more information on how the dithering -is actually done. @code{w3-color-filter} may also be a string, specifying -exactly what external filter to use. An example is: @samp{ppmquant -fs --map ~/pixmaps/colormap.ppm}. +The search for the property value can be terminated whenever one rule +has a higher weight than the other rules that apply to the same +element/property combination. + +This strategy gives author's style sheets considerably higher weight +than those of the reader. It is therefore important that the reader has +the ability to turn off the influence of a certain style sheet, +e.g. through a pull-down menu. + +A declaration in the 'STYLE' attribute of an element has the same weight +as a declaration with an ID-based selector that is specified at the end +of the style sheet: + +@example +<STYLE TYPE="text/css"> + #x97z @{ color: blue @} +</STYLE> + +<P ID=x97z STYLE="color: red"> +@end example + +In the above example, the color of the 'P' element would be +red. Although the specificity is the same for both declarations, the +declaration in the 'STYLE' attribute will override the one in the +'STYLE' element because of cascading rule number 5. + +The UA may choose to honor other stylistic HTML attributes, for example +'ALIGN'. If so, these attributes are translated to the corresponding CSS +rules with specificity equal to 1. The rules are assumed to be at the +start of the author style sheet and may be overridden by subsequent +style sheet rules. In a transition phase, this policy will make it +easier for stylistic attributes to coexist with style sheets. + +@node Properties, Font Properties, The Cascade, Stylesheets +@section Properties +@ifinfo +@menu +* Font Properties:: Selecting fonts, styles, and sizes. +* Colors and Backgrounds:: Controlling colors, front and back. +* Text Properties:: Alignment, decoration, and more! +* Box Properties:: Borders, padding, and margins, oh my! +* Classification:: Changing whitespace and display policies. +* Media Selection:: +* Speech Properties:: +@end menu +@end ifinfo + +@node Font Properties, font-family, Properties, Properties +@subsection Font Properties +Setting font properties will be among the most common uses of style +sheets. Unfortunately, there exists no well-defined and universally +accepted taxonomy for classifying fonts, and terms that apply to one +font family may not be appropriate for others. E.g. 'italic' is commonly +used to label slanted text, but slanted text may also be labeled as +being @b{Oblique}, @b{Slanted}, @b{Incline}, @b{Cursive} or +@b{Kursiv}. Therefore it is not a simple problem to map typical font +selection properties to a specific font. + +The properties defined by CSS1 are described in the following sections. +@ifinfo +@menu +* font-family:: Groups of fonts. +* font-style:: Normal, italic, or oblique? +* font-variant:: Small-caps, etc. +* font-weight:: How bold can you go? +* font-size:: How big is yours? +* font:: Shorthand for all of the above. +@end menu +@end ifinfo + +@node font-family, font-style, Font Properties, Font Properties +@subsubsection font-family + +@multitable @columnfractions .20 .8 +@item Supported Values: @tab [[<family-name> | <generic-family>],]* [<family-name> | <generic-family>] +@item Initial: @tab User specific +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable +The value is a prioritized list of font family names and/or generic +family names. Unlike most other CSS1 properties, values are separated +by a comma to indicate that they are alternatives: + +@example + BODY @{ font-family: gill, helvetica, sans-serif @} +@end example + +There are two types of list values: + +@table @b +@item <family-name> +The name of a font family of choice. In the last example, "gill" and +"helvetica" are font families. +@item <generic-family> +In the example above, the last value is a generic family name. The +following generic families are defined: +@itemize @bullet +@item +'serif' (e.g. Times) +@item +'sans-serif' (e.g. Helvetica) +@item +'cursive' (e.g. Zapf-Chancery) +@item +'fantasy' (e.g. Western) +@item +'monospace' (e.g. Courier) +@end itemize +@end table -@cindex MPEGs -@cindex Inlined animations -When running in XEmacs 19.11 or XEmacs 19.12, Emacs-W3 can insert an -MPEG movie in the middle of a buffer. +Style sheet designers are encouraged to offer a generic font family as a +last alternative. + +Font names containing whitespace should be quoted: + +@example + BODY @{ font-family: "new century schoolbook", serif @} + + <BODY STYLE="font-family: 'My own font', fantasy"> +@end example + +If quoting is omitted, any whitespace characters before and after the +font name are ignored and any sequence of whitespace characters inside +the font name is converted to a single space. + +@node font-style, font-variant, font-family, Font Properties +@subsubsection font-style + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab normal | italic | oblique +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +The 'font-style' property selects between normal (sometimes referred to +as "roman" or "upright"), italic and oblique faces within a font family. + +A value of 'normal' selects a font that is classified as 'normal' in the +UA's font database, while 'oblique' selects a font that is labeled +'oblique'. A value of 'italic' selects a font that is labeled 'italic', +or, if that is not available, one labeled 'oblique'. + +The font that is labeled 'oblique' in the UA's font database may +actually have been generated by electronically slanting a normal font. + +Fonts with Oblique, Slanted or Incline in their names will typically be +labeled 'oblique' in the UA's font database. Fonts with Italic, Cursive +or Kursiv in their names will typically be labeled 'italic'. + +@example + H1, H2, H3 @{ font-style: italic @} + H1 EM @{ font-style: normal @} +@end example + +In the example above, emphasized text within 'H1' will appear in a +normal face. + +@node font-variant, font-weight, font-style, Font Properties +@subsubsection font-variant -:: WORK :: Need a pointer to the new EMBED Internet Draft :: +@multitable @columnfractions .2 .8 +@item Value: @tab normal | small-caps +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +Another type of variation within a font family is the small-caps. In a +small-caps font the lower case letters look similar to the uppercase +ones, but in a smaller size and with slightly different proportions. The +'font-variant' property selects that font. + +A value of 'normal' selects a font that is not a small-caps font, +'small-caps' selects a small-caps font. It is acceptable (but not +required) in CSS1 if the small-caps font is a created by taking a normal +font and replacing the lower case letters by scaled uppercase +characters. As a last resort, uppercase letters will be used as +replacement for a small-caps font. + +The following example results in an 'H3' element in small-caps, with +emphasized words in oblique small-caps: + +@example + H3 @{ font-variant: small-caps @} + EM @{ font-style: oblique @} +@end example -The basic syntax is: +There may be other variants in the font family as well, such as fonts +with old-style numerals, small-caps numerals, condensed or expanded +letters, etc. CSS1 has no properties that select those. + +@node font-weight, font-size, font-variant, Font Properties +@subsubsection font-weight + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab normal | bold | 100 | 200 | 300 | 400 | 500 | 600 | 700 | 800 | 900 +@item Unsupported Values: @tab bolder | lighter +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +The 'font-weight' property selects the weight of the font. The values +'100' to '900' form an ordered sequence, where each number indicates a +weight that is at least as dark as its predecessor. The keyword 'normal' +is synonymous with '400', and 'bold' is synonymous with '700'. Keywords +other than 'normal' and 'bold' have been shown to be often confused with +font names and a numerical scale was therefore chosen for the 9-value +list. + @example -<embed href="somevideo.mpg" type="video/mpeg"> + P @{ font-weight: normal @} /* 400 */ + H1 @{ font-weight: 700 @} /* bold */ +@end example + +The 'bolder' and 'lighter' values select font weights that are relative +to the weight inherited from the parent: + +@example + STRONG @{ font-weight: bolder @} @end example -@vindex w3-mpeg-args -@vindex w3-mpeg-program -This requires a special version of the standard @file{mpeg_play} mpeg -player. Patches against the 2.0 version are available at -ftp://ftp.cs.indiana.edu/pub/elisp/w3/mpeg_patch. The variable -@code{w3-mpeg-program} should point to this executable, and -@code{w3-mpeg-args} should be a list of any additional arguments to be -passed to the player. By default, this includes @var{-loop}, so the -mpeg plays continuously. +There is no guarantee that there will be a darker face for each of the +'font-weight' values; for example, some fonts may have only a normal and +a bold face, others may have eight different face weights. There is no +guarantee on how a UA will map font faces within a family to weight +values. The only guarantee is that a face of a given value will be no +less dark than the faces of lighter values. + +@node font-size, font, font-weight, Font Properties +@subsubsection font-size + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab <absolute-size> | <length> +@item Unsupported Values: @tab <percentage> | <relative-size> +@item Initial: @tab medium +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab relative to parent element's font size +@end multitable + +@table @b +@item <absolute-size> +An <absolute-size> keyword is an index to a table of font sizes computed +and kept by the UA. Possible values are: +@itemize @bullet +@item +xx-small +@item +x-small +@item +small +@item +medium +@item +large +@item +x-large +@item +xx-large +@end itemize + +On a computer screen a scaling factor of 1.5 is suggested between +adjacent indexes; if the 'medium' font is 10pt, the 'large' font could +be 15pt. Different media may need different scaling factors. Also, the +UA should take the quality and availability of fonts into account when +computing the table. The table may be different from one font family to +another. +@item <relative-size> +A <relative-size> keyword is interpreted relative to the table of font +sizes and the font size of the parent element. Possible values are +@b{larger} or @b{smaller}. For example, if the parent element has a font +size of 'medium', a value of 'larger' will make the font size of the +current element be 'large'. If the parent element's size is not close to +a table entry, the UA is free to interpolate between table entries or +round off to the closest one. The UA may have to extrapolate table +values if the numerical value goes beyond the keywords. +@end table + +Length and percentage values should not take the font size table into +account when calculating the font size of the element. + +Negative values are not allowed. + +On all other properties, 'em' and 'ex' length values refer to the font +size of the current element. On the 'font-size' property, these length +units refer to the font size of the parent element. + +Note that an application may reinterpret an explicit size, depending on +the context. E.g., inside a VR scene a font may get a different size +because of perspective distortion. + +Examples: + +@example + P @{ font-size: 12pt; @} + BLOCKQUOTE @{ font-size: larger @} + EM @{ font-size: 150% @} + EM @{ font-size: 1.5em @} +@end example + +If the suggested scaling factor of 1.5 is used, the last three +declarations are identical. + +@node font, Colors and Backgrounds, font-size, Font Properties +@subsubsection font + +@multitable @columnfractions .2 .8 +@item Value: @tab [ <font-style> || <font-variant> || <font-weight> ]? <font-size> [ / <line-height> ]? <font-family> +@item Initial: @tab not defined for shorthand properties +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab allowed on <font-size> and <line-height> +@end multitable +The 'font' property is a shorthand property for setting 'font-style' +'font-variant' 'font-weight' 'font-size', 'line-height' and +'font-family' at the same place in the style sheet. The syntax of this +property is based on a traditional typographical shorthand notation to +set multiple properties related to fonts. + +For a definition of allowed and initial values, see the previously +defined properties. Properties for which no values are given are set to +their initial value. + +@example + P @{ font: 12pt/14pt sans-serif @} + P @{ font: 80% sans-serif @} + P @{ font: x-large/110% "new century schoolbook", serif @} + P @{ font: bold italic large Palatino, serif @} + P @{ font: normal small-caps 120%/120% fantasy @} +@end example + +In the second rule, the font size percentage value ('80%') refers to the +font size of the parent element. In the third rule, the line height +percentage refers to the font size of the element itself. + +In the first three rules above, the 'font-style', 'font-variant' and +'font-weight' are not explicitly mentioned, which means they are all +three set to their initial value ('normal'). The fourth rule sets the +'font-weight' to 'bold', the 'font-style' to 'italic' and implicitly +sets 'font-variant' to 'normal'. + +The fifth rule sets the 'font-variant' ('small-caps'), the 'font-size' +(120% of the parent's font), the 'line-height' (120% times the font +size) and the 'font-family' ('fantasy'). It follows that the keyword +'normal' applies to the two remaining properties: 'font-style' and +'font-weight'. + +@node Colors and Backgrounds, color, font, Properties +@subsection Colors and Backgrounds +These properties describe the color (often called foreground color) and +background of an element (i.e. the surface onto which the content is +rendered). One can set a background color and/or a background image. The +position of the image, if/how it is repeated, and whether it is fixed or +scrolled relative to the canvas can also be set. + +The 'color' property inherits normally. The background properties do not +inherit, but the parent element's background will shine through by +default because of the initial 'transparent' value on +'background-color'. + +NOTE: Currently, Emacs-W3 can only show background images under XEmacs. +Emacs 19 doesn't have the support in its display code yet. + +@ifinfo +@menu +* color:: Foreground colors. +* background-color:: Background colors. +* background-image:: Background images. +* background-repeat:: Controlling repeating of background images. +* background-attachment:: Where background images are drawn. +* background-position:: Where background images are drawn. +* background:: Shorthand for all background properties. +@end menu +@end ifinfo + +@node color, background-color, Colors and Backgrounds, Colors and Backgrounds +@subsubsection color +@multitable @columnfractions .2 .8 +@item Value: @tab <color> +@item Initial: @tab User specific +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +This property describes the text color of an element (often referred to +as the foreground color). There are different ways to specify red: + +@example + EM @{ color: red @} /* natural language */ + EM @{ color: rgb(255,0,0) @} /* RGB range 0-255 */ +@end example + +See @ref{Color Units} for a description of possible color values. + +@node background-color, background-image, color, Colors and Backgrounds +@subsubsection background-color +@multitable @columnfractions .2 .8 +@item Value: @tab <color> | transparent +@item Initial: @tab transparent +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab N/A +@end multitable -@cindex Delaying inlined images -@cindex Delaying inlined animations -@vindex w3-delay-image-loads -@vindex w3-delay-mpeg-loads -Because images and movies can take up an incredible amount of bandwidth, -it is useful to be able to control whether they are loaded or not. By -default, images and movies are loaded automatically, but the variables -@code{w3-delay-image-loads} and @code{w3-delay-mpeg-loads} control this. -If set to non-@code{nil}, then the images or movies are not -loaded until explicitly requested by the user. +This property sets the background color of an element. + +@example + H1 @{ background-color: #F00 @} +@end example + +@node background-image, background-repeat, background-color, Colors and Backgrounds +@subsubsection background-image +@multitable @columnfractions .2 .8 +@item Value: @tab <url> | none +@item Initial: @tab none +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab N/A +@end multitable + +This property sets the background image of an element. When setting a +background image, one should also set a background color that will be +used when the image is unavailable. When the image is available, it is +overlaid on top of the background color. + +@example + BODY @{ background-image: url(marble.gif) @} + P @{ background-image: none @} +@end example + +@node background-repeat, background-attachment, background-image, Colors and Backgrounds +@subsubsection background-repeat +This property is not supported at all under Emacs-W3. + +@node background-attachment, background-position, background-repeat, Colors and Backgrounds +@subsubsection background-attachment +This property is not supported at all under Emacs-W3. + +@node background-position, background, background-attachment, Colors and Backgrounds +@subsubsection background-position +This property is not supported at all under Emacs-W3. + +@node background, Text Properties, background-position, Colors and Backgrounds +@subsubsection background +@multitable @columnfractions .2 .8 +@item Value: @tab <background-color> || <background-image> || <background-repeat> || <background-attachment> || <background-position> +@item Initial: @tab not defined for shorthand properties +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab allowed on <background-position> +@end multitable + +The 'background' property is a shorthand property for setting the +individual background properties (i.e., 'background-color', +'background-image', 'background-repeat', 'background-attachment' and +'background-position') at the same place in the style sheet. + +Possible values on the 'background' properties are the set of all +possible values on the individual properties. + +@example + BODY @{ background: red @} + P @{ background: url(chess.png) gray 50% repeat fixed @} +@end example + +The 'background' property always sets all the individual background +properties. In the first rule of the above example, only a value for +'background-color' has been given and the other individual properties +are set to their initial value. In the second rule, all individual +properties have been specified. + +@node Text Properties, word-spacing, background, Properties +@subsection Text Properties + +@ifinfo +@menu +* word-spacing:: +* letter-spacing:: +* text-decoration:: +* vertical-align:: +* text-transform:: +* text-align:: +* text-indent:: +* line-height:: +@end menu +@end ifinfo + +@node word-spacing, letter-spacing, Text Properties, Text Properties +@subsubsection word-spacing +@multitable @columnfractions .2 .8 +@end multitable -@cindex Loading delayed images -@cindex Loading delayed movies -@findex w3-load-delayed-images -@findex w3-load-delayed-mpegs -To load any delayed images, use the function -@code{w3-load-delayed-images}. Its counterpart for delayed movies is -@code{w3-load-delayed-mpegs} +@node letter-spacing, text-decoration, word-spacing, Text Properties +@subsubsection letter-spacing +@multitable @columnfractions .2 .8 +@end multitable + +@node text-decoration, vertical-align, letter-spacing , Text Properties +@subsubsection text-decoration +@multitable @columnfractions .2 .8 +@end multitable + +@node vertical-align, text-transform, text-decoration, Text Properties +@subsubsection vertical-align +@multitable @columnfractions .2 .8 +@end multitable + +@node text-transform, text-align, vertical-align, Text Properties +@subsubsection text-transform +@multitable @columnfractions .2 .8 +@end multitable + +@node text-align, text-indent, text-transform, Text Properties +@subsubsection text-align +@multitable @columnfractions .2 .8 +@end multitable + +@node text-indent, line-height, text-align, Text Properties +@subsubsection +@multitable @columnfractions .2 .8 +@end multitable + +@node line-height, Box Properties, text-indent, Text Properties +@subsubsection +@multitable @columnfractions .2 .8 +@end multitable + +@node Box Properties, Classification, line-height, Properties +@subsection Box Properties +@multitable @columnfractions .2 .8 +@end multitable + +@node Classification, Media Selection, Box Properties, Properties +@subsection Classification +@multitable @columnfractions .2 .8 +@end multitable -@node MIME Support, Adding MIME types based on file extensions, , Top +@node Media Selection, Speech Properties, Classification, Properties +@subsection Media Selection +@multitable @columnfractions .2 .8 +@end multitable + +@node Speech Properties, Units, Media Selection, Properties +@subsection Speech Properties +@multitable @columnfractions .2 .8 +@end multitable + +@node Units, Length Units, Speech Properties, Stylesheets +@section Units + +@ifinfo +@menu +* Length Units:: +* Percentage Units:: +* Color Units:: +* URLs:: +* Angle Units:: +* Time Units:: +@end menu +@end ifinfo + +@node Length Units, Percentage Units, Units, Units +@subsection Length Units + +@node Percentage Units, Color Units, Length Units, Units +@subsection Percentage Units + +@node Color Units, URLs, Percentage Units, Units +@subsection color Units + +@node URLs, Angle Units, Color Units, Units +@subsection URLs + +@node Angle Units, Time Units, URLs, Units +@subsection Angle Units + +@node Time Units, Supported URLs, Angle Units, Units +@subsection Time Units + +@node Supported URLs, MIME Support, Time Units, Top +@chapter Supported URLs + +::WORK:: List supported URL types, specific RFCs, etc. + +@node MIME Support, Adding MIME types based on file extensions, Supported URLs, Top @chapter MIME Support -MIME is an emerging standard for multimedia mail. It offers a very +@sc{mime} is an emerging standard for multimedia mail. It offers a very flexible typing mechanism. The type of a file or message is specified in two parts, separated by a '/'. The first part is the general category of the data (text, application, image, etc.). The second part is the specific type of data (postscript, gif, jpeg, etc.). So -@samp{text/html} specifies an HTML document, whereas +@samp{text/html} specifies an @sc{html} document, whereas @samp{image/x-xwindowdump} specifies an image of an Xwindow taken with the @file{xwd} program. -This typing allows much more flexibility in naming files. HTTP/1.0 +This typing allows much more flexibility in naming files. @sc{http}/1.0 servers can now send back content-type headers in response to a request, -and not have the client second-guess it based on file extensions. HTML +and not have the client second-guess it based on file extensions. @sc{html} files can now be named @file{something.gif} (not a great idea, but possible). @@ -1495,8 +1799,8 @@ @vindex mm-mime-extensions For some protocols however, it is still necessary to guess the content of a file based on the file extension. This type of guess-work should -only be needed when accessing files via FTP, local file access, or old -HTTP/0.9 servers. +only be needed when accessing files via @sc{ftp}, local file access, or old +@sc{http}/0.9 servers. Instead of specifying how to view things twice, once based on content-type and once based on the file extension, it is easier to map @@ -1512,7 +1816,7 @@ @cindex mime-types file @findex mm-parse-mimetypes -Both Mosaic and the NCSA HTTP daemon rely on a separate file for mapping +Both Mosaic and the NCSA @sc{http} daemon rely on a separate file for mapping file extensions to MIME types. Instead of having the users of Emacs-W3 duplicate this in lisp, this file can be parsed using the @code{url-parse-mimetypes} function. This function is called each time @@ -1535,7 +1839,7 @@ @file{/usr/local/www/conf/mime-types} @end enumerate -Each line contains information for one http type. These types resemble +Each line contains information for one @sc{http} type. These types resemble MIME types. To add new ones, use subtypes beginning with x-, such as application/x-myprogram. Lines beginning with # are comment lines, and suitably ignored. Each line consists of: @@ -1548,7 +1852,7 @@ @node Specifying Viewers, ,Adding MIME types based on file extensions, MIME Support @section Specifying Viewers -Not all files look as they should when parsed as an HTML document +Not all files look as they should when parsed as an @sc{html} document (whitespace is stripped, paragraphs are reformatted, and lots of little changes that make the document look unrecognizable). Files may be passed to external programs or Emacs Lisp functions to be viewed. @@ -1562,7 +1866,7 @@ As an alternative, the function @code{mm-add-mailcap-entry} can also be used from an appropriate hook.@xref{Hooks} This functions takes three arguments, the major type ("@i{image}"), the minor type ("@i{gif}"), and -an assoc list of information about the viewer. Please see the URL +an assoc list of information about the viewer. Please see the @sc{url} documentation for more specific information on what this assoc list should look like. @@ -1601,25 +1905,8 @@ @cindex Export Restrictions SSL is the @code{Secure Sockets Layer} interface developed by Netscape Communications @footnote{http://www.netscape.com/}. Emacs-W3 supports -HTTP transfers over an SSL encrypted channel, if the appropriate files +@sc{http} transfers over an SSL encrypted channel, if the appropriate files have been installed.@xref{Installing SSL} -@item PGP/PEM -@cindex HTTP/1.0 Authentication -@cindex Public Key Cryptography -@cindex Authentication, PGP -@cindex Authentication, PEM -@cindex RIPEM -@cindex Public Key Cryptography -@cindex PGP -@cindex Pretty Good Privacy -@cindex Encryption -@cindex Security -@cindex ITAR must die -@cindex Stupid export restrictions -@cindex Support your local crypto-anarchist -@cindex NSA freaks -A few servers still support this method of authentication, but it has -been superseded by SSL and Secure-HTTP.@xref{Using PGP/PEM} @end table @node Non-Unix Operating Systems, VMS, Security, Top @@ -1630,8 +1917,7 @@ * VMS:: The wonderful world of VAX|AXP-VMS! * OS/2:: The next-best thing to Unix. * MS-DOS:: The wonderful world of MS-DOG! -* 32-Bit Windows:: Windows NT, Chicago/Windows 95. -* Amiga:: The Amiga, for those who still love them. +* Windows:: Windows NT, Chicago/Windows 95. @end menu @end ifinfo @@ -1649,7 +1935,7 @@ @cindex Warp :: WORK :: OS/2 Specific instructions -@node MS-DOS, 32-Bit Windows, OS/2, Non-Unix Operating Systems +@node MS-DOS, Windows, OS/2, Non-Unix Operating Systems @section MS-DOS @cindex MS-DOS @cindex Microsloth @@ -1657,21 +1943,19 @@ @cindex MS-DOG :: WORK :: DOS Specific instructions -@node 32-Bit Windows, Amiga, MS-DOS, Non-Unix Operating Systems -@section 32-Bit Windows +@node Windows, Speech Integration , MS-DOS, Non-Unix Operating Systems +@section Windows @cindex Windows (32-Bit) @cindex 32-Bit Windows @cindex Microsloth @cindex Windows '95 :: WORK :: 32bit Windows Specific instructions -@node Amiga, Advanced Features, 32-Bit Windows, Non-Unix Operating Systems -@section Amiga -@cindex Amiga -@cindex Commodore -:: WORK :: Amiga specific instructions +@node Speech Integration, Advanced Features, Windows, Top +@chapter Speech Integration +:: WORK :: Emacspeak integration -@node Advanced Features, Style Sheets, Amiga, Top +@node Advanced Features, Style Sheets, Speech Integration, Top @chapter Advanced Features @ifinfo @@ -1680,7 +1964,7 @@ * Disk Caching:: Improving performance by using a local disk cache * Interfacing to Mail/News:: How to make VM understand hypertext links * Debugging HTML:: How to make Emacs-W3 display warnings about invalid - HTML/HTML+ constructs. + @sc{html}/@sc{html}+ constructs. * Native WAIS Support:: How to make Emacs-W3 understand WAIS links without using a gateway. * Rating Links:: How to make Emacs-W3 put an 'interestingness' value @@ -1730,13 +2014,13 @@ To include a stylesheet into a document, simply use the <style> tag. Use the @b{notation} attribute to specify what language the stylesheet is specified in. The default is @b{css}. The data between the <style> -and </style> tags is the stylsheet proper - no HTML parsing is done to +and </style> tags is the stylsheet proper - no @sc{html} parsing is done to this data - it is treated similar to an <XMP> section of text. To reference an external stylesheet, use the <link> tag. @example <link rel="stylesheet" href="/bill.style"> @end example -If these two mechanisms are mixed, then the URL is resolved first, and +If these two mechanisms are mixed, then the @sc{url} is resolved first, and the contents of the <style> tag take precedence if there are any conflicting directives. @@ -1804,7 +2088,7 @@ Emacs-W3 caches files under the temporary directory specified by @code{url-temporary-directory}, in a user-specific subdirectory (determined by the @code{user-real-login-name} function). The cache -files are stored under their original names, so a URL like: +files are stored under their original names, so a @sc{url} like: http://www.aventail.com/foo/bar/baz.html would be stored in a cache file named: /tmp/wmperry/com/aventail/www/foo/bar/baz.html. Sometimes, espcially with gopher links, there will be name conflicts, and an error @@ -1838,18 +2122,18 @@ @cindex Using Emacs-W3 with Gnus @cindex RMAIL @cindex Using Emacs-W3 with RMAIL -More and more people are including URLs in their signatures, and within +More and more people are including @sc{url}s in their signatures, and within the body of mail messages. It can get quite tedious to type these into the minibuffer to follow one. @vindex browse-url-browser-function With the latest versions of VM (the 5.9x series of betas) and Gnus -(5.x), URLs are automatically highlighted, and can be followed with the -mouse or the return key. How the URLs are viewed is determined by the +(5.x), @sc{url}s are automatically highlighted, and can be followed with the +mouse or the return key. How the @sc{url}s are viewed is determined by the variable @code{browse-url-browser-function}, and it should be set to the symbol @code{browse-url-w3}. -To access URLs from within RMAIL, the following hook should do the +To access @sc{url}s from within RMAIL, the following hook should do the trick. @example (add-hook 'rmail-mode-hook @@ -1867,11 +2151,11 @@ @vindex w3-debug-buffer @vindex w3-debug-html For those people that are adventurous, or are just as anal as I am about -people writing valid HTML, set the variable @code{w3-debug-html} to +people writing valid @sc{html}, set the variable @code{w3-debug-html} to @code{t} and see what happens. -If a Emacs-W3 thinks it has encountered invalid HTML, then a debugging +If a Emacs-W3 thinks it has encountered invalid @sc{html}, then a debugging message is displayed. :: WORK :: Need to list the different values w3-debug-html can have, and @@ -1892,17 +2176,17 @@ one of @code{url-wais-gateway-server} or @code{url-wais-gateway-port} should be @code{nil}. -When a WAIS URL is encountered, a form will be automatically generated +When a WAIS @sc{url} is encountered, a form will be automatically generated and displayed. After typing in the search term, the query will be sent to the server by running the @code{url-waisq-prog} in a subprocess. The -results will be converted into HTML and displayed. +results will be converted into @sc{html} and displayed. @node Rating Links, Gopher Plus Support, Native WAIS Support, Advanced Features @section Rating Links -The @code{w3-link-info-display-function} variable can be used to 'rate' a URL -when it shows up in an HTML page. If non-@code{nil}, then this should +The @code{w3-link-info-display-function} variable can be used to 'rate' a @sc{url} +when it shows up in an @sc{html} page. If non-@code{nil}, then this should be a list specifying (or a symbol specifying the name) of a function. -This function should expect one argument, a fully specified URL, and +This function should expect one argument, a fully specified @sc{url}, and should return a string. This string is inserted after the link text. @@ -1925,7 +2209,7 @@ @section Gopher+ Support @cindex Gopher+ The gopher+ support in Emacs-W3 is limited to the conversion of ASK -blocks into HTML 3.0 forms, and the usage of the content-length given by +blocks into @sc{html} 3.0 forms, and the usage of the content-length given by the gopher+ server to give a nice status bar on the bottom of the screen. @@ -1943,7 +2227,7 @@ @table @code @vindex w3-load-hooks @item w3-load-hooks -These hooks are run by @code{w3-do-setup} the first time a URL is +These hooks are run by @code{w3-do-setup} the first time a @sc{url} is fetched. All the w3 variables are initialized before this hook is run. @item w3-file-done-hooks @@ -1954,10 +2238,9 @@ are downloaded and converted. @item w3-file-prepare-hooks These hooks are run by @code{w3-prepare-buffer} before any parsing is -done on the HTML file. The HTTP/1.0 headers specified by -@code{w3-show-headers} have been inserted, the syntax table has been set -to @code{w3-parse-args-syntax-table}, and any personal annotations have -been inserted by the time this hook is run. +done on the @sc{html} file. The @sc{http}/1.0 headers specified by +@code{w3-show-headers} have been inserted, and the syntax table has been +set to @code{w3-parse-args-syntax-table} by the time this hook is run. @item w3-mode-hooks These hooks are run after a buffer has been parsed and displayed, but before any inlined images are downloaded and converted. @@ -1974,7 +2257,7 @@ @item url-bad-port-list @vindex url-bad-port-list List of ports to warn the user about connecting to. Defaults to just -the mail and NNTP ports so a malicious HTML author cannot spoof mail or +the mail and @sc{nntp} ports so a malicious @sc{html} author cannot spoof mail or news to other people. @item url-confirmation-func @vindex url-confirmation-func @@ -2027,10 +2310,10 @@ document. @item w3-show-headers @vindex w3-show-headers -This is a list of HTTP/1.0 headers to show at the end of a buffer. All +This is a list of @sc{http}/1.0 headers to show at the end of a buffer. All the headers should be in lowercase. They are inserted at the end of the buffer in a <UL> list. Alternatively, if this is simply @code{t}, then -all the HTTP/1.0 headers are shown. The default value is +all the @sc{http}/1.0 headers are shown. The default value is @code{nil}. @item w3-show-status, url-show-status @vindex url-show-status @@ -2063,7 +2346,7 @@ @vindex url-uncompressor-alist An assoc list of file extensions and the appropriate uncompression programs for each. This is used to build the Accept-encoding header for -HTTP/1.0 requests. +@sc{http}/1.0 requests. @item url-waisq-prog @vindex url-waisq-prog Name of the waisq executable on this system. This should be the @@ -2127,15 +2410,259 @@ :: WORK :: Revamp the todo list -@node Reporting Bugs, Installing SSL, Future Directions, Top +@node Reporting Bugs, Dealing with Firewalls, Future Directions, Top @appendix Reporting Bugs @cindex Reporting Bugs @cindex Bugs @cindex Contacting the author -:: WORK :: Reporting bugs needs work. +If any bugs are discovered in Emacs-W3, please report them to the +mailing list @t{w3-beta@@indiana.edu} - this is where the brave souls +who beta test the latest versions of Emacs-W3 reside, and are generally +very responsive to bug reports. + +@kindex w +Please make sure to use the bug submission feature of Emacs-W3, so that +all relevant information will be sent along with your bug report. By +default this is bound to the `@key{w}' key when in an Emacs-W3 buffer, +or you can use @key{M-x w3-submit-bug} from anywhere within Emacs. + +For problems that are causing emacs to signal and error, please send a +backtrace. You can get a backtrace by @kbd{M-x setvariable RET +debug-on-error RET t RET}, and then reproduce the error. + +If the problem is visual, please capture a copy of the output and mail +it along with the bug report (preferably as a MIME attachment, but +anything will do). You can use the @code{xwd} program under X-windows +for this, or @key{Alt-PrintScreen} under Windows 95/NT. Sorry, but I +don't remember what the magic incarnation is for doing a screen dump +under NeXTstep or OS/2. + +If the problem is actually causing Emacs to crash, then you will need to +also mail the maintainers of the various Emacs distributions with the +bug. Please use the @t{gnu.emacs.bug} newgroup for reporting bugs with +GNU Emacs 19, and @t{comp.emacs.xemacs} for reporting bugs with XEmacs +19 or XEmacs 20. I am actively involved with the beta testing of the +latest versions of both branches of Emacs, and if I can reproduce the +problem, I will do my best to see it gets fixed in the next release. + +It is also important to always maintain as much context as possible in +your responses. I get so much email from my various Emacs-activities +and work, that I cannot remember everything. If you send a bug report, +and I send you a reply, and you reply with 'no that didn't work', then +odds are I will have no clue what didn't work, much less what that was +trying to fix in the first place. It will be much quicker and less +painful if I don't have to waste a round-trip email exchange saying +'what are you talking about'. + +@node Dealing with Firewalls, Proxy Gateways, Reporting Bugs, Top +@appendix Dealing with Firewalls +By default, Emacs can support standard @sc{tcp}/@sc{ip} network +connections on almost all the platforms it runs on (Unix, @sc{vms}, +Windows, etc). However, there are several situations where it is not +sufficient. + +@table @b +@cindex Firewalls +@item Firewalls +It is becoming more and more common to be behind a firewall or some +other system that restricts your outbound network activity, especially +if you are like me and away from the wonderful world of academia. +Emacs-W3 has several different methods to get around firewalls (not to +worry though - none of them should get you in trouble with the local +@sc{mis} department.) + +@item Emacs cannot resolve hostnames. +@cindex Faulty hostname resolvers +@cindex Broken SunOS libc +@cindex Hostname resolution +This happens quite often on SunOS workstations and some ULTRIX machines. +Some C libraries do not include the hostname resolver routines in their +static libraries. If Emacs was linked statically, and was not linked +with the resolver libraries, it wil not be able to get to any machines +off the local network. This is characterized by being able to reach +someplace with a raw ip number, but not its hostname +(@url{http://129.79.254.191/} works, but +@url{http://www.cs.indiana.edu/} doesn't). + +The best solution for this problem is to recompile Emacs, making sure to +either link dynamically (if available on your operating system), or +include the @file{-lresolv}. + +@cindex url-gateway-broken-resolution +If you do not have the disk space or the appropriate permissions to +recompile Emacs, another alternative is using the @file{nslookup} +program to do hostname resolution. To turn this on, set the variable +@code{url-gateway-broken-resolution} in your @file{~/.emacs} file. This +runs the program specified by @code{url-gateway-nslookup-program} (by +default "@code{nslookup}" to do hostname resolution. This program should +expect a single argument on the command line - the hostname to resolve, +and should produce output similar to the standard Unix @file{nslookup} +program: + +@example +Name: www.cs.indiana.ed +Address: 129.79.254.191 +@end example + +@cindex @sc{term} +@item Using @sc{term} (or @sc{term}-like) Networking Software +@sc{term} @footnote{@sc{term} is a user-level protocol for emulating +@sc{ip} over a serial line. More information is available at +@url{ftp://sunsite.unc.edu/pub/Linux/apps/comm/term}} for slip-like +access to the internet. + +@sc{note}: XEmacs and Emacs 19.22 or later have patches to enable native +@sc{term} networking. To enable it, @code{#define TERM} in the +appropriate s/*.h file for the operating system, then change the +@code{SYSTEM_LIBS} definition to include the @file{termnet} library that +comes with the latest versions of @sc{term}. + +If you run into any problems with the native @sc{term} networking +support in Emacs or XEmacs, please let @t{wmperry@@cs.indiana.edu} know, +as he is responsible for the original support. +@end table + +@vindex url-gateway-local-host-regexp +Emacs-W3 has support for using the gateway mechanism for certain +domains, and directly connecting to others. The variable +@code{url-gateway-local-host-regexp} controls this behaviour. This is a +regular expression @footnote{Please see the full Emacs distribution for +a description of regular expressions} that matches local hosts that do +not require the use of a gateway. If @code{nil}, then all connections +are made through the gateway. + +@vindex url-gateway-method +Emacs-W3 supports several methods of getting around gateways. The +variable @code{url-gateway-method} controls which of these methods is +used. This variable can have several values (use these as symbol names, +not strings), ie: @samp{(setq url-gateway-method 'telnet)}. Possible +values are: -@node Installing SSL, Using PGP/PEM, Reporting Bugs, Top +@table @dfn +@item telnet +Use this method if you must first telnet and log into a gateway host, +and then run telnet from that host to connect to outside machines. + +:: WORK :: document telnet gw variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item url-gateway-telnet-host +@item url-gateway-telnet-parameters +@item url-gateway-telnet-password-prompt +@item url-gateway-telnet-puser-name +@item url-gateway-prompt-pattern +@end table + +@item rlogin +This method is identical to the @code{telnet} method, but uses +@file{rlogin} to log into the remote machine without having to send the +username and password over the wire every time. + +:: WORK :: document rlogin gw variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item url-gateway-rlogin-host +@item url-gateway-rlogin-parameters +@item url-gateway-rlogin-user-name +@item url-gateway-prompt-pattern +@end table + +@item tcp +Masanobu UMEDA (@i{umerin@@mse.kyutech.ac.jp}) has written a very small +application that you can run in a subprocess to do the network +connections. + +@item @sc{socks} +Use if the firewall has a @sc{socks} gateway running on it. + +:: WORK :: document socks variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item socks-host +@item socks-password +@item socks-username +@item socks-port +@item socks-timeout +@end table + +@c @item ssl +@c This probably shouldn't be documented + +@item native +This means that Emacs-W3 should use the builtin networking code of +Emacs. This should be used only if there is no firewall, or the Emacs +source has already been hacked to get around the firewall. +@end table + +Emacs-W3 should now be able to get outside the local network. If none +of this makes sense, its probably my fault. Please check with the +network administrators to see if they have a program that does most of +this already, since somebody somewhere at the company has probably been +through something similar to this before, and would be much more +helpful/knowledgeable about the local setup than I would be. But feel +free to mail me as a last resort. + +@node Proxy Gateways, Installing SSL, Dealing with Firewalls, Top +@appendix Proxy Gateways +@vindex url-proxy-services +@cindex Proxy Servers +@cindex Proxies +@cindex Proxies, environment variables +@cindex HTTP Proxy + +In late January 1993, Kevin Altis and Lou Montulli proposed and +implemented a new proxy service. This service requires the use of +environment variables to specify a gateway server/port # to send +protocol requests to. Each protocol (@sc{http}, @sc{wais}, gopher, +@sc{ftp}, etc.) can have a different gateway server. The environment +variables are @code{PROTOCOL}_proxy, where @code{PROTOCOL} is one of the +supported network protocols (gopher, file, @sc{http}, @sc{ftp}, etc.) + +@cindex No Proxy +@cindex Proxies, exclusion lists +@vindex NO_PROXY +For companies with internal intranets, it will usually be helpful to +define a list of hosts that should be contacted directly, @b{not} sent +through the proxy. The @code{NO_PROXY} environment variable controls +what hosts are able to be contacted directly. This should be a comma +separated list of hostnames, domain names, or a mixture of both. +Asterisks can be used as a wildcard. For example: + +@example +NO_PROXY=*.aventail.com,home.com,*.seanet.com +@end example + +tells Emacs-W3 to contact all machines in the @b{aventail.com} and +@b{seanet.com} domains directly, as well as the machine named +@b{home.com}. + +@vindex url-proxy-services +@cindex Proxies, setting from lisp +For those adventurous souls who enjoy writing regular expressions, all +the proxy settings can be manipulated from Emacs-Lisp. The variable +@code{url-proxy-services} controls this. This is an assoc list, keyed +on the protocol type (@sc{http}, gopher, etc) in all lowercase. The +@code{cdr} of each entry should be the fully-specified @sc{url} of the proxy +server to contact, or, in the case of the special "no_proxy" entry, a +regular expression that matches any hostnames that should be contacted +directly. + +@example +(setq url-proxy-services '(("http" . "http://proxy.aventail.com/") + ("no_proxy" . "^.*\\(aventail\\|seanet\\)\.com"))) +@end example + +@node Installing SSL, Mailcap Files, Proxy Gateways, Top @appendix Installing SSL @cindex HTTP/1.0 Authentication @cindex Secure Sockets Layer @@ -2171,115 +2698,7 @@ be distributing a set of patches to Emacs 19.xx and XEmacs 19.xx to SSL-enable them, for the sake of speed. -@node Using PGP/PEM, Mailcap Files, Installing SSL, Top -@appendix Using PGP/PEM -@cindex HTTP/1.0 Authentication -@cindex Public Key Cryptography -@cindex Authentication, PGP -@cindex Authentication, PEM -@cindex RIPEM -@cindex Public Key Cryptography -@cindex PGP -@cindex Pretty Good Privacy -@cindex Encryption -@cindex Security -@cindex ITAR must die -@cindex Stupid export restrictions -@cindex Support your local crypto-anarchist -@cindex NSA freaks -Most of this chapter has been reproduced from the original documentation -written by Rob McCool (@i{robm@@netscape.com})@footnote{See -http://hoohoo.ncsa.uiuc.edu/docs/PEMPGP.html for the original}. - -RIPEM is 'Riordan's Internet Privacy Enhanced Mail', and is currently on -version 1.2b3. US citizens can ftp it from -ftp://ripem.msu.edu/pub/crypt/ripem. - -PGP is 'Pretty Good Privacy', and is currently on version 2.6. The -legal controversies that plagued earlier versions have been resolved, so -this is a competely legal program now. There is also a legal version -for european users, called 2.6ui (the Unofficial International -version). - -PGP and PEM are programs that allow two parties to communicate in a way -which does not allow third parties to read them, and which certify that -the person who sent the message is really who they claim they are. - - -PGP and PEM both use RSA encryption. The U.S. government has strict -export controls over foreign use of this technology, so people outside -the U.S. may have a difficult time finding programs which perform the -encryption. - -A working copy of either Pretty Good Privacy or RIPEM is required. You -should be familiar with the program and have generated a public/private -key pair. - - -Currently, the protocol has been implemented with PEM and PGP using -local key files on the server side, and on the client side with PEM -using finger to retrieve the server's public key. - -Parties who wish to use Emacs-W3 with PEM or PGP encryption will need to -communicate beforehand and find a tamper-proof way to exchange their -public keys. - -Pioneers get shot full of arrows. This work is currently in the -experimental stages and thus may have some problems that I have -overlooked. The only known problem that I know about is that the -messages are currently not timestamped. This means that a malicious -user could record the encrypted message with a packet sniffer and repeat -it back to the server ad nauseum. Although they would not be able to -read the reply, if the request was for something being charged for, this -could be very inconvenient. - -This protocol is almost word-for-word a copy of Tony Sander's RIPEM -based scheme, generalized a little. Below, wherever PEM is used, -replace it with PGP, and the behaviour should remain the same. - -@example -*Client:* - -GET /docs/protected.html HTTP/1.0 -UserAgent: Emacs-W3/2.1.x - -*Server:* - -HTTP/1.0 401 Unauthorized -WWW-Authenticate: PEM entity="webmaster@@hoohoo.ncsa.uiuc.edu" -Server: NCSA/1.1 - -*Client:* - -GET / HTTP/1.0 -Authorization: PEM entity="robm@@ncsa.uiuc.edu" -Content-type: application/x-www-pem-request - ---- BEGIN PRIVACY-ENHANCED MESSAGE --- -this is the real request, encrypted ---- END PRIVACY-ENHANCED MESSAGE --- - -*Server:* - -HTTP/1.0 200 OK -Content-type: application/x-www-pem-reply - ---- BEGIN PRIVACY-ENHANCED MESSAGE --- -this is the real reply, encrypted ---- END PRIVACY-ENHANCED MESSAGE --- -That's it. -@end example - -@cindex Mailcrypt -Emacs-W3 uses the excellent @i{mailcrypt}@footnote{Available from -http://www.cs.indiana.edu/LCD/cover.html?mailcrypt} package written by -Jin S Choi (@i{jsc@@mit.edu}). This package takes care of calling ripem -and/or pgp with the correct arguments. Please see the documentation at -the top of mailcrypt.el for instructions on using mailcrypt. All bug -reports about mailcrypt should go to Jin S Choi, but bugs about how I -use it in Emacs-W3 should of course be directed to me. - -@node Mailcap Files, General Index, Using PGP/PEM, Top +@node Mailcap Files, Down with DoubleClick, Installing SSL, Top @appendix Mailcap Files NCSA Mosaic and almost all other WWW browsers rely on a separate file for mapping MIME types to external viewing programs. This takes some of @@ -2413,7 +2832,12 @@ document. @end itemize -@node General Index, Key Index, Mailcap Files, Top +@node Down with DoubleClick, General Index, Mailcap Files, Top +@appendix Down with DoubleClick +:: WORK :: Document why doubleclick is evil +:: WORK :: Document how you can never see another ad from them again + +@node General Index, Key Index, Down with DoubleClick, Top @appendix General Index @printindex fn @node Key Index, , General Index, Top @@ -2421,3 +2845,76 @@ @printindex ky @contents @bye + +@c @node Supported Protocols, , Stylesheets, Introduction +@c @chapter Supported Protocols +@c @cindex Network Protocols +@c @cindex Protocols Supported +@c @cindex Supported Protocols +@c Emacs-W3 supports the following protocols +@c @table @b +@c @item Usenet News +@c Can either display an entire newsgroup or specific articles by +@c Message-ID: header. Instead of rewriting a newsreader, this integrates +@c with the Gnus newsreader. It requires at least Gnus 5.0, but it is +@c always safest to use the latest version. Gnus supports some very +@c advanced features, including virtual newsgroups, mail and news +@c integration, and reading news from multiple servers. @inforef{Gnus, +@c Top,gnus}, for more info. + +@c To be more in line with the other @sc{url} schemes, the hostname and port of +@c an @sc{nntp} server can be specified. @sc{url}s of the form +@c news://hostname:port/messageID work, but might not work in some other +@c browsers. + +@c @item @sc{http} +@c Supports the @sc{http}/0.9, @sc{http}/1.0, and parts of the @sc{http}/1.1 protocols. +@c @item Gopher +@c Support for all gopher types, including CSO queries. +@c @item Gopher+ +@c Support for Gopher+ retrievals. Support for converting ASK blocks into +@c HTML forms and submitting them back to the server. +@c @item @sc{ftp} +@c @sc{ftp} is handled by either ange-ftp or efs. +@c @inforef{Ange-FTP,Top,ange-ftp}, for more information on Ange-FTP, or +@c @inforef{EFS, Top,efs}, for information on EFS. +@c @item Local files +@c Local files are of course handled, and MIME content-types are derived +@c from the file extensions. +@c @item telnet, tn3270, rlogin +@c Telnet, tn3270, and rogin are handled by running the appropriate program +@c in an emacs buffer, or running an external process. +@c @item mailto +@c Causes a mail message to be started to a specific address. Supports the +@c Netscape @i{extensions} to specify arbitrary headers on the message. +@c @item data +@c A quick and easy way to `inline' small pieces of information that you do +@c not necessarily want to download over the net separately. Can speed up +@c display of small icons, stylesheet information, etc. See the internet +@c draft draft-masinter-url-data-02.txt for more information. +@c @item mailserver +@c A more powerful version of mailto, which allows the author to specify +@c the subject and body text of the mail message. This type of link is +@c never fully executed without user confirmation, because it is possible +@c to insert insulting or threatening (and possibly illegal) data into the +@c message. The mail message is displayed, and the user must confirm the +@c message before it is sent. +@c @item x-exec +@c A @sc{url} can cause a local executable to be run, and its output interpreted +@c as if it had come from an @sc{http} server. This is very useful, but is +@c still an experimental protocol, hence the X- prefix. This @sc{url} protocol +@c is deprecated, but might be useful in the future. +@c @item @sc{nfs} +@c Retrieves information over @sc{nfs}. This requires that your operating +@c system support auto-mounting of @sc{nfs} volumes. +@c @item finger +@c Retrieves information about a user via the 'finger' protocol. +@c @item Info +@c Creates a link to an GNU-style info file. @inforef{Info,Top,info}, for more +@c information on the Info format. +@c @item SSL +@c SSL requires a set of patches to the Emacs C code and SSLRef 2.0, or an +@c external program to run in a subprocess (similar to the @file{tcp.el} +@c package that comes with GNUS. @xref{Installing SSL} +@c @end table + diff -r 498bf5da1c90 -r 0d2f883870bc man/widget.texi --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/man/widget.texi Mon Aug 13 09:13:56 2007 +0200 @@ -0,0 +1,1348 @@ +\input texinfo.tex + +@c $Id: widget.texi,v 1.2 1997/02/15 22:21:57 steve Exp $ + +@c %**start of header +@setfilename widget +@settitle The Emacs Widget Library +@iftex +@afourpaper +@headings double +@end iftex +@c %**end of header + +@node Top, Introduction, (dir), (dir) +@comment node-name, next, previous, up +@top The Emacs Widget Library + +Version: 1.40 + +@menu +* Introduction:: +* User Interface:: +* Programming Example:: +* Setting Up the Buffer:: +* Basic Types:: +* Sexp Types:: +* Widget Properties:: +* Defining New Widgets:: +* Widget Wishlist.:: +@end menu + +@node Introduction, User Interface, Top, Top +@comment node-name, next, previous, up +@section Introduction + +Most graphical user interface toolkits, such as Motif and XView, provide +a number of standard user interface controls (sometimes known as +`widgets' or `gadgets'). Emacs doesn't really support anything like +this, except for an incredible powerful text ``widget''. On the other +hand, Emacs does provide the necessary primitives to implement many +other widgets within a text buffer. The @code{widget} package +simplifies this task. + +The basic widgets are: + +@table @code +@item link +Areas of text with an associated action. Intended for hypertext links +embedded in text. +@item push-button +Like link, but intended for stand-alone buttons. +@item editable-field +An editable text field. It can be either variable or fixed length. +@item menu-choice +Allows the user to choose one of multiple options from a menu, each +option is itself a widget. Only the selected option will be visible in +the buffer. +@item radio-button-choice +Allows the user to choose one of multiple options by pushing radio +buttons. The options are implemented as widgets. All options will be +visible in the buffer. +@item item +A simple constant widget intended to be used in the @code{menu-choice} and +@code{radio-button-choice} widgets. +@item choice-item +An button item only intended for use in choices. When pushed, the user +will be asked to select another option from the choice widget. +@item toggle +A simple @samp{on}/@samp{off} switch. +@item checkbox +A checkbox (@samp{[ ]}/@samp{[X]}). +@item editable-list +Create an editable list. The user can insert or delete items in the +list. Each list item is itself a widget. +@end table + +Now of what possible use can support for widgets be in a text editor? +I'm glad you asked. The answer is that widgets are useful for +implementing forms. A @dfn{form} in emacs is a buffer where the user is +supposed to fill out a number of fields, each of which has a specific +meaning. The user is not supposed to change or delete any of the text +between the fields. Examples of forms in Emacs are the @file{forms} +package (of course), the customize buffers, the mail and news compose +modes, and the @sc{html} form support in the @file{w3} browser. + +The advantages for a programmer of using the @code{widget} package to +implement forms are: + +@enumerate +@item +More complex field than just editable text are supported. +@item +You can give the user immediate feedback if he enters invalid data in a +text field, and sometimes prevent entering invalid data. +@item +You can have fixed sized fields, thus allowing multiple field to be +lined up in columns. +@item +It is simple to query or set the value of a field. +@item +Editing happens in buffer, not in the mini-buffer. +@item +Packages using the library get a uniform look, making them easier for +the user to learn. +@item +As support for embedded graphics improve, the widget library will +extended to support it. This means that your code using the widget +library will also use the new graphic features by automatic. +@end enumerate + +In order to minimize the code that is loaded by users who does not +create any widgets, the code has been split in two files: + +@table @file +@item widget.el +This will declare the user variables, define the function +@code{widget-define}, and autoload the function @code{widget-create}. +@item widget-edit.el +Everything else is here, there is no reason to load it explicitly, as +it will be autoloaded when needed. +@end table + +@node User Interface, Programming Example, Introduction, Top +@comment node-name, next, previous, up +@section User Interface + +A form consist of read only text for documentation and some fields, +where each the fields contain two parts, as tag and a value. The tags +are used to identify the fields, so the documentation can refer to the +foo field, meaning the field tagged with @samp{Foo}. Here is an example +form: + +@example +Here is some documentation. + +Name: @i{My Name} @strong{Choose}: This option +Address: @i{Some Place +In some City +Some country.} + +See also @b{_other work_} for more information. + +Numbers: count to three below +@b{[INS]} @b{[DEL]} @i{One} +@b{[INS]} @b{[DEL]} @i{Eh, two?} +@b{[INS]} @b{[DEL]} @i{Five!} +@b{[INS]} + +Select multiple: + +@b{[X]} This +@b{[ ]} That +@b{[X]} Thus + +Select one: + +@b{(*)} One +@b{( )} Another One. +@b{( )} A Final One. + +@b{[Apply Form]} @b{[Reset Form]} +@end example + +The top level widgets in is example are tagged @samp{Name}, +@samp{Choose}, @samp{Address}, @samp{_other work_}, @samp{Numbers}, +@samp{Select multiple}, @samp{Select one}, @samp{[Apply Form]}, and +@samp{[Reset Form]}. There are basically two thing the user can do within +a form, namely editing the editable text fields and activating the +buttons. + +@subsection Editable Text Fields + +In the example, the value for the @samp{Name} is most likely displayed +in an editable text field, and so are values for each of the members of +the @samp{Numbers} list. All the normal Emacs editing operations are +available for editing these fields. The only restriction is that each +change you make must be contained within a single editable text field. +For example, capitalizing all text from the middle of one field to the +middle of another field is prohibited. + +Editing text fields are created by the @code{editable-field} widget. + +The editing text fields are highlighted with the +@code{widget-field-face} face, making them easy to find. + +@deffn Face widget-field-face +Face used for other editing fields. +@end deffn + +@subsection Buttons + +Some portions of the buffer have an associated @dfn{action}, which can +be @dfn{activated} by a standard key or mouse command. These portions +are called @dfn{buttons}. The default commands for activating a button +are: + +@table @kbd +@item @key{RET} +@deffn Command widget-button-press @var{pos} &optional @var{event} +Activate the button at @var{pos}, defaulting to point. +If point is not located on a button, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn + +@item mouse-2 +@deffn Command widget-button-click @var{event} +Activate the button at the location of the mouse pointer. If the mouse +pointer is located in an editable text field, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn +@end table + +There are several different kind of buttons, all of which are present in +the example: + +@table @emph +@item The Option Field Tags. +When you activate one of these buttons, you will be asked to choose +between a number of different options. This is how you edit an option +field. Option fields are created by the @code{menu-choice} widget. In +the example, @samp{@b{Choose}} is an option field tag. +@item The @samp{@b{[INS]}} and @samp{@b{[DEL]}} buttons. +Activating these will insert or delete elements from a editable list. +The list is created by the @code{editable-list} widget. +@item Embedded Buttons. +The @samp{@b{_other work_}} is an example of an embedded +button. Embedded buttons are not associated with a fields, but can serve +any purpose, such as implementing hypertext references. They are +usually created by the @code{link} widget. +@item The @samp{@b{[ ]}} and @samp{@b{[X]}} buttons. +Activating one of these will convert it to the other. This is useful +for implementing multiple-choice fields. You can create it wit +@item The @samp{@b{( )}} and @samp{@b{(*)}} buttons. +Only one radio button in a @code{radio-button-choice} widget can be selected at any +time. When you push one of the unselected radio buttons, it will be +selected and the previous selected radio button will become unselected. +@item The @samp{@b{[Apply Form]}} @samp{@b{[Reset Form]}} buttons. +These are explicit buttons made with the @code{push-button} widget. The main +difference from the @code{link} widget is that the buttons are will be +displayed as GUI buttons when possible. +enough. +@end table + +To make them easier to locate, buttons are emphasized in the buffer. + +@deffn Face widget-button-face +Face used for buttons. +@end deffn + +@defopt widget-mouse-face +Face used for buttons when the mouse pointer is above it. +@end defopt + +@subsection Navigation + +You can use all the normal Emacs commands to move around in a form +buffer, plus you will have these additional commands: + +@table @kbd +@item @key{TAB} +@deffn Command widget-forward &optional count +Move point @var{count} buttons or editing fields forward. +@end deffn +@item @key{M-TAB} +@deffn Command widget-backward &optional count +Move point @var{count} buttons or editing fields backward. +@end deffn +@end table + +@node Programming Example, Setting Up the Buffer, User Interface, Top +@comment node-name, next, previous, up +@section Programming Example + +Here is the code to implement the user interface example (see @ref{User +Interface}). + +@lisp +(require 'widget) + +(eval-when-compile + (require 'widget-edit)) + +(defvar widget-example-repeat) + +(defun widget-example () + "Create the widgets from the Widget manual." + (interactive) + (switch-to-buffer "*Widget Example*") + (kill-all-local-variables) + (make-local-variable 'widget-example-repeat) + (let ((inhibit-read-only t)) + (erase-buffer)) + (widget-insert "Here is some documentation.\n\nName: ") + (widget-create 'editable-field + :size 13 + "My Name") + (widget-create 'menu-choice + :tag "Choose" + :value "This" + :help-echo "Choose me, please!" + :notify (lambda (widget &rest ignore) + (message "%s is a good choice!" + (widget-value widget))) + '(item :tag "This option" :value "This") + '(choice-item "That option") + '(editable-field :menu-tag "No option" "Thus option")) + (widget-insert "Address: ") + (widget-create 'editable-field + "Some Place\nIn some City\nSome country.") + (widget-insert "\nSee also ") + (widget-create 'link + :notify (lambda (&rest ignore) + (widget-value-set widget-example-repeat + '("En" "To" "Tre")) + (widget-setup)) + "other work") + (widget-insert " for more information.\n\nNumbers: count to three below\n") + (setq widget-example-repeat + (widget-create 'editable-list + :entry-format "%i %d %v" + :notify (lambda (widget &rest ignore) + (let ((old (widget-get widget + ':example-length)) + (new (length (widget-value widget)))) + (unless (eq old new) + (widget-put widget ':example-length new) + (message "You can count to %d." new)))) + :value '("One" "Eh, two?" "Five!") + '(editable-field :value "three"))) + (widget-insert "\n\nSelect multiple:\n\n") + (widget-create 'checkbox t) + (widget-insert " This\n") + (widget-create 'checkbox nil) + (widget-insert " That\n") + (widget-create 'checkbox + :notify (lambda (&rest ignore) (message "Tickle")) + t) + (widget-insert " Thus\n\nSelect one:\n\n") + (widget-create 'radio-button-choice + :value "One" + :notify (lambda (widget &rest ignore) + (message "You selected %s" + (widget-value widget))) + '(item "One") '(item "Anthor One.") '(item "A Final One.")) + (widget-insert "\n") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (if (= (length (widget-value widget-example-repeat)) + 3) + (message "Congratulation!") + (error "Three was the count!"))) + "Apply Form") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (widget-example)) + "Reset Form") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup)) +@end lisp + +@node Setting Up the Buffer, Basic Types, Programming Example, Top +@comment node-name, next, previous, up +@section Setting Up the Buffer + +Widgets are created with @code{widget-create}, which returns a +@dfn{widget} object. This object can be queried and manipulated by +other widget functions, until it is deleted with @code{widget-delete}. +After the widgets have been created, @code{widget-setup} must be called +to enable them. + +@defun widget-create type [ keyword argument ]@dots{} +Create and return a widget of type @var{type}. +The syntax for the @var{type} argument is described in @ref{Basic Types}. + +The keyword arguments can be used to overwrite the keyword arguments +that are part of @var{type}. +@end defun + +@defun widget-delete widget +Delete @var{widget} and remove it from the buffer. +@end defun + +@defun widget-setup +Setup a buffer to support widgets. + +This should be called after creating all the widgets and before allowing +the user to edit them. +@refill +@end defun + +If you want to insert text outside the widgets in the form, the +recommended way to do that is with @code{widget-insert}. + +@defun widget-insert +Insert the arguments, either strings or characters, at point. +The inserted text will be read only. +@end defun + +There is a standard widget keymap which you might find useful. + +@defvr Const widget-keymap +A keymap with the global keymap as its parent.@br +@key{TAB} and @kbd{C-@key{TAB}} are bound to @code{widget-forward} and +@code{widget-backward}, respectively. @kbd{@key{RET}} and @kbd{mouse-2} +are bound to @code{widget-button-press} and +@code{widget-button-}.@refill +@end defvr + +@defvar widget-global-map +Keymap used by @code{widget-button-press} and @code{widget-button-click} +when not on a button. By default this is @code{global-map}. +@end defvar + +@node Basic Types, Sexp Types, Setting Up the Buffer, Top +@comment node-name, next, previous, up +@section Basic Types + +The syntax of a type specification is given below: + +@example +NAME ::= (NAME [KEYWORD ARGUMENT]... ARGS) + | NAME +@end example + +Where, @var{name} is a widget name, @var{keyword} is the name of a +property, @var{argument} is the value of the property, and @var{args} +are interpreted in a widget specific way. + +There following keyword arguments that apply to all widgets: + +@table @code +@item :value +The initial value for widgets of this type. + +@item :format +This string will be inserted in the buffer when you create a widget. +The following @samp{%} escapes are available: + +@table @samp +@item %[ +@itemx %] +The text inside will be marked as a button. + +@item %@{ +@itemx %@} +The text inside will be displayed with the face specified by +@code{:sample-face}. + +@item %v +This will be replaces with the buffer representation of the widgets +value. What this is depends on the widget type. + +@item %d +Insert the string specified by @code{:doc} here. + +@item %h +Like @samp{%d}, with the following modifications: If the documentation +string is more than one line, it will add a button which will toggle +between showing only the first line, and showing the full text. +Furthermore, if there is no @code{:doc} property in the widget, it will +instead examine the @code{:documentation-property} property. If it is a +lambda expression, it will be called with the widget's value as an +argument, and the result will be used as the documentation text. + +@item %t +Insert the string specified by @code{:tag} here, or the @code{princ} +representation of the value if there is no tag. + +@item %% +Insert a literal @samp{%}. +@end table + +@item :button-face +Face used to highlight text inside %[ %] in the format. + +@item :doc +The string inserted by the @samp{%d} escape in the format +string. + +@item :tag +The string inserted by the @samp{%t} escape in the format +string. + +@item :tag-glyph +Name of image to use instead of the string specified by `:tag' on +Emacsen that supports it. + +@item :help-echo +Message displayed whenever you move to the widget with either +@code{widget-forward} or @code{widget-backward}. + +@item :indent +An integer indicating the absolute number of spaces to indent children +of this widget. + +@item :offset +An integer indicating how many extra spaces to add to the widget's +grandchildren compared to this widget. + +@item :extra-offset +An integer indicating how many extra spaces to add to the widget's +children compared to this widget. + +@item :notify +A function called each time the widget or a nested widget is changed. +The function is called with two or three arguments. The first argument +is the widget itself, the second argument is the widget that was +changed, and the third argument is the event leading to the change, if +any. + +@item :menu-tag +Tag used in the menu when the widget is used as an option in a +@code{menu-choice} widget. + +@item :menu-tag-get +Function used for finding the tag when the widget is used as an option +in a @code{menu-choice} widget. By default, the tag used will be either the +@code{:menu-tag} or @code{:tag} property if present, or the @code{princ} +representation of the @code{:value} property if not. + +@item :match +Should be a function called with two arguments, the widget and a value, +and returning non-nil if the widget can represent the specified value. + +@item :validate +A function which takes a widget as an argument, and return nil if the +widgets current value is valid for the widget. Otherwise, it should +return the widget containing the invalid data, and set that widgets +@code{:error} property to a string explaining the error. + +@item :parent +The parent of a nested widget (e.g. a @code{menu-choice} item or an element of a +@code{editable-list} widget). +@end table + +@deffn {User Option} widget-glyph-directory +Directory where glyphs are found. +Widget will look here for a file with the same name as specified for the +image, with either a @samp{.xpm} (if supported) or @samp{.xbm} extension. +@end deffn + +@deffn{User Option} widget-glyph-enable +If non-nil, allow glyphs to appear on displayes where they are supported. +@end deffn + + +@menu +* link:: +* url-link:: +* info-link:: +* push-button:: +* editable-field:: +* text:: +* menu-choice:: +* radio-button-choice:: +* item:: +* choice-item:: +* toggle:: +* checkbox:: +* checklist:: +* editable-list:: +@end menu + +@node link, url-link, Basic Types, Basic Types +@comment node-name, next, previous, up +@subsection The @code{link} Widget + +Syntax: + +@example +TYPE ::= (link [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +@node url-link, info-link, link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{url-link} Widget + +Syntax: + +@example +TYPE ::= (url-link [KEYWORD ARGUMENT]... URL) +@end example + +When this link is activated, the @sc{www} browser specified by +@code{browse-url-browser-function} will be called with @var{url}. + +@node info-link, push-button, url-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{info-link} Widget + +Syntax: + +@example +TYPE ::= (info-link [KEYWORD ARGUMENT]... ADDRESS) +@end example + +When this link is activated, the build-in info browser is started on +@var{address}. + +@node push-button, editable-field, info-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{push-button} Widget + +Syntax: + +@example +TYPE ::= (push-button [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +@node editable-field, text, push-button, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-field} Widget + +Syntax: + +@example +TYPE ::= (editable-field [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in +field. This widget will match all string values. + +The following extra properties are recognized. + +@table @code +@item :size +The width of the editable field.@br +By default the field will reach to the end of the line. + +@item :value-face +Face used for highlighting the editable field. Default is +@code{widget-field-face}. + +@item :secret +Character used to display the value. You can set this to e.g. @code{?*} +if the field contains a password or other secret information. By +default, the value is not secret. + +@item :valid-regexp +By default the @code{:validate} function will match the content of the +field with the value of this attribute. The default value is @code{""} +which matches everything. + +@item :keymap +Keymap used in the editable field. The default value is +@code{widget-field-keymap}, which allows you to use all the normal +editing commands, even if the buffers major mode supress some of them. +Pressing return activates the function specified by @code{:activate}. + +@item :hide-front-space +@itemx :hide-rear-space +In order to keep track of the editable field, emacs places an invisible +space character in front of the field, and for fixed sized fields also +in the rear end of the field. For fields that extent to the end of the +line, the terminating linefeed serves that purpose instead. + +Emacs will try to make the spaces intangible when it is safe to do so. +Intangible means that the cursor motion commands will skip over the +character as if it didn't exist. This is safe to do when the text +preceding or following the widget cannot possible change during the +lifetime of the @code{editable-field} widget. The preferred way to tell +Emacs this, is to add text to the @code{:format} property around the +value. For example @code{:format "Tag: %v "}. + +You can overwrite the internal safety check by setting the +@code{:hide-front-space} or @code{:hide-rear-space} properties to +non-nil. This is not recommended. For example, @emph{all} text that +belongs to a widget (i.e. is created from its @code{:format} string) will +change whenever the widget changes its value. + +@end table + +@node text, menu-choice, editable-field, Basic Types +@comment node-name, next, previous, up +@subsection The @code{text} Widget + +This is just like @code{editable-field}, but intended for multiline text +fields. The default @code{:keymap} is @code{widget-text-keymap}, which +does not rebind the return key. + +@node menu-choice, radio-button-choice, text, Basic Types +@comment node-name, next, previous, up +@subsection The @code{menu-choice} Widget + +Syntax: + +@example +TYPE ::= (menu-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +@table @code +@item :void +Widget type used as a fallback when the value does not match any of the +specified @var{type} arguments. + +@item :case-fold +Set this to nil if you don't want to ignore case when prompting for a +choice through the minibuffer. + +@item :children +A list whose car is the widget representing the currently chosen type in +the buffer. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +@node radio-button-choice, item, menu-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{radio-button-choice} Widget + +Syntax: + +@example +TYPE ::= (radio-button-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the radio button. +@item %% +Insert a literal @samp{%}. +@end table + +@item :buttons +The widgets representing the radio buttons. + +@item :children +The widgets representing each type. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +You can add extra radio button items to a @code{radio-button-choice} +widget after it has been created with the function +@code{widget-radio-add-item}. + +@defun widget-radio-add-item widget type +Add to @code{radio-button-choice} widget @var{widget} a new radio button item of type +@var{type}. +@end defun + +Please note that such items added after the @code{radio-button-choice} +widget has been created will @strong{not} be properly destructed when +you call @code{widget-delete}. + +@node item, choice-item, radio-button-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{item} Widget + +Syntax: + +@example +ITEM ::= (item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. This widget will only match the specified value. + +@node choice-item, toggle, item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{choice-item} Widget + +Syntax: + +@example +ITEM ::= (choice-item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer as a button. Activating the button of a @code{choice-item} is +equivalent to activating the parent widget. This widget will only match +the specified value. + +@node toggle, checkbox, choice-item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{toggle} Widget + +Syntax: + +@example +TYPE ::= (toggle [KEYWORD ARGUMENT]...) +@end example + +The widget has two possible states, `on' and `off', which corresponds to +a @code{t} or @code{nil} value. + +The following extra properties are recognized. + +@table @code +@item :on +String representing the `on' state. By default the string @samp{on}. +@item :off +String representing the `off' state. By default the string @samp{off}. +@item :on-glyph +Name of a glyph to be used instead of the `:on' text string, on emacsen +that supports it. +@item :off-glyph +Name of a glyph to be used instead of the `:off' text string, on emacsen +that supports it. +@end table + +@node checkbox, checklist, toggle, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checkbox} Widget + +The widget has two possible states, `selected' and `unselected', which +corresponds to a @code{t} or @code{nil} value. + +Syntax: + +@example +TYPE ::= (checkbox [KEYWORD ARGUMENT]...) +@end example + +@node checklist, editable-list, checkbox, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checklist} Widget + +Syntax: + +@example +TYPE ::= (checklist [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each checklist item. The widgets +value of will be a list containing the value of each ticked @var{type} +argument. The checklist widget will match a list whose elements all +matches at least one of the specified @var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the checkbox. +@item %% +Insert a literal @samp{%}. +@end table + +@item :buttons +The widgets representing the checkboxes. + +@item :children +The widgets representing each type. + +@item :args +The list of types. +@end table + +@node editable-list, , checklist, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-list} Widget + +Syntax: + +@example +TYPE ::= (editable-list [KEYWORD ARGUMENT]... TYPE) +@end example + +The value is a list, where each member represent one widget of type +@var{type}. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +This will be replaced with the buffer representation of the @var{type} +widget. +@item %i +Insert the @b{[INS]} button. +@item %d +Insert the @b{[DEL]} button. +@item %% +Insert a literal @samp{%}. +@end table + +@item :buttons +The widgets representing the insert and delete buttons. + +@item :children +The widgets representing the elements of the list. + +@item :args +List whose car is the type of the list elements. + +@end table + +@node Sexp Types, Widget Properties, Basic Types, Top +@comment +@section Sexp Types + +A number of widgets for editing s-expressions (lisp types) are also +available. These basically fall in three categories: @dfn{atoms}, +@dfn{composite types}, and @dfn{generic}. + +@menu +* generic:: +* atoms:: +* composite:: +@end menu + +@node generic, atoms, Sexp Types, Sexp Types +@comment node-name, next, previous, up +@subsection The Generic Widget. + +The @code{const} and @code{sexp} widgets can contain any lisp +expression. In the case of the @code{const} widget the user is +prohibited from editing edit it, which is mainly useful as a component +of one of the composite widgets. + +The syntax for the generic widgets is + +@example +TYPE ::= (const [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and can be any s-expression. + +@deffn Widget const +This will display any valid s-expression in an immutable part of the +buffer. +@end deffn + +@deffn Widget sexp +This will allow you to edit any valid s-expression in an editable buffer +field. + +The @code{sexp} widget takes the same keyword arguments as the +@code{editable-field} widget. +@end deffn + +@node atoms, composite, generic, Sexp Types +@comment node-name, next, previous, up +@subsection Atomic Sexp Widgets. + +The atoms are s-expressions that does not consist of other +s-expressions. A string is an atom, while a list is a composite type. +You can edit the value of an atom with the following widgets. + +The syntax for all the atoms are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and must be an expression of the same type as the widget. +I.e. the string widget can only be initialized with a string. + +All the atom widgets take the same keyword arguments as the @code{editable-field} +widget. + +@deffn Widget string +Allows you to edit a string in an editable field. +@end deffn + +@deffn Widget file +Allows you to edit a file name in an editable field. You you activate +the tag button, you can edit the file name in the mini-buffer with +completion. + +Keywords: +@table @code +@item :must-match +If this is set to non-nil, only existing file names will be allowed in +the minibuffer. +@end table +@end deffn + +@deffn Widget directory +Allows you to edit a directory name in an editable field. +Similar to the @code{file} widget. +@end deffn + +@deffn Widget symbol +Allows you to edit a lisp symbol in an editable field. +@end deffn + +@deffn Widget integer +Allows you to edit an integer in an editable field. +@end deffn + +@deffn Widget number +Allows you to edit a number in an editable field. +@end deffn + +@deffn Widget boolean +Allows you to edit a boolean. In lisp this means a variable which is +either nil meaning false, or non-nil meaning true. +@end deffn + + +@node composite, , atoms, Sexp Types +@comment node-name, next, previous, up +@subsection Composite Sexp Widgets. + +The syntax for the composite are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... COMPONENT...) +@end example + +Where each @var{component} must be a widget type. Each component widget +will be displayed in the buffer, and be editable to the user. + +@deffn Widget cons +The value of a @code{cons} widget is a cons-cell where the car is the +value of the first component and the cdr is the value of the second +component. There must be exactly two components. +@end deffn + +@deffn Widget lisp +The value of a @code{lisp} widget is a list containing the value of +each of its component. +@end deffn + +@deffn Widget vector +The value of a @code{vector} widget is a vector containing the value of +each of its component. +@end deffn + +The above suffice for specifying fixed size lists and vectors. To get +variable length lists and vectors, you can use a @code{choice}, +@code{set} or @code{repeat} widgets together with the @code{:inline} +keywords. If any component of a composite widget has the @code{:inline} +keyword set, its value must be a list which will then be spliced into +the composite. For example, to specify a list whose first element must +be a file name, and whose remaining arguments should either by the +symbol @code{t} or two files, you can use the following widget +specification: + +@example +(list file + (choice (const t) + (list :inline t + :value ("foo" "bar") + string string))) +@end example + +The value of a widget of this type will either have the form +@samp{(file t)} or @code{(file string string)}. + +This concept of inline is probably hard to understand. It was certainly +hard to implement so instead of confuse you more by trying to explain it +here, I'll just suggest you meditate over it for a while. + +@deffn Widget choice +Allows you to edit a sexp which may have one of fixed set of types. It +is currently implemented with the @code{choice-menu} basic widget, and +has a similar syntax. +@end deffn + +@deffn Widget set +Allows you to specify a type which must be a list whose elements all +belong to given set. The elements of the list is not significant. This +is implemented on top of the @code{checklist} basic widget, and has a +similar syntax. +@end deffn + +@deffn Widget repeat +Allows you to specify a variable length list whose members are all of +the same type. Implemented on top of the `editable-list' basic widget, +and has a similar syntax. +@end deffn + +@node Widget Properties, Defining New Widgets, Sexp Types, Top +@comment node-name, next, previous, up +@section Properties + +You can examine or set the value of a widget by using the widget object +that was returned by @code{widget-create}. + +@defun widget-value widget +Return the current value contained in @var{widget}. +It is an error to call this function on an uninitialized widget. +@end defun + +@defun widget-value-set widget value +Set the value contained in @var{widget} to @var{value}. +It is an error to call this function with an invalid @var{value}. +@end defun + +@strong{Important:} You @emph{must} call @code{widget-setup} after +modifying the value of a widget before the user is allowed to edit the +widget again. It is enough to call @code{widget-setup} once if you +modify multiple widgets. This is currently only necessary if the widget +contains an editing field, but may be necessary for other widgets in the +future. + +If your application needs to associate some information with the widget +objects, for example a reference to the item being edited, it can be +done with @code{widget-put} and @code{widget-get}. The property names +must begin with a @samp{:}. + +@defun widget-put widget property value +In @var{widget} set @var{property} to @var{value}. +@var{property} should be a symbol, while @var{value} can be anything. +@end defun + +@defun widget-get widget property +In @var{widget} return the value for @var{property}. +@var{property} should be a symbol, the value is what was last set by +@code{widget-put} for @var{property}. +@end defun + +@defun widget-member widget property +Non-nil if @var{widget} has a value (even nil) for property @var{property}. +@end defun + +Occasionally it can be useful to know which kind of widget you have, +i.e. the name of the widget type you gave when the widget was created. + +@defun widget-type widget +Return the name of @var{widget}, a symbol. +@end defun + +@node Defining New Widgets, Widget Wishlist., Widget Properties, Top +@comment node-name, next, previous, up +@section Defining New Widgets + +You can define specialized widgets with @code{define-widget}. It allows +you to create a shorthand for more complex widgets, including specifying +component widgets and default new default values for the keyword +arguments. + +@defun widget-define name class doc &rest args +Define a new widget type named @var{name} from @code{class}. + +@var{name} and class should both be symbols, @code{class} should be one +of the existing widget types. + +The third argument @var{DOC} is a documentation string for the widget. + +After the new widget has been defined, the following two calls will +create identical widgets: + +@itemize @bullet +@item +@lisp +(widget-create @var{name}) +@end lisp + +@item +@lisp +(apply widget-create @var{class} @var{args}) +@end lisp +@end itemize + +@end defun + +Using @code{widget-define} does just store the definition of the widget +type in the @code{widget-type} property of @var{name}, which is what +@code{widget-create} uses. + +If you just want to specify defaults for keywords with no complex +conversions, you can use @code{identity} as your conversion function. + +The following additional keyword arguments are useful when defining new +widgets: +@table @code +@item :convert-widget +Function to convert a widget type before creating a widget of that +type. It takes a widget type as an argument, and returns the converted +widget type. When a widget is created, this function is called for the +widget type and all the widgets parent types, most derived first. + +@item :value-to-internal +Function to convert the value to the internal format. The function +takes two arguments, a widget and an external value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :value-to-external +Function to convert the value to the external format. The function +takes two arguments, a widget and an internal value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :create +Function to create a widget from scratch. The function takes one +argument, a widget type, and create a widget of that type, insert it in +the buffer, and return a widget object. + +@item :delete +Function to delete a widget. The function takes one argument, a widget, +and should remove all traces of the widget from the buffer. + +@item :value-create +Function to expand the @samp{%v} escape in the format string. It will +be called with the widget as its argument. Should +insert a representation of the widgets value in the buffer. + +@item :value-delete +Should remove the representation of the widgets value from the buffer. +It will be called with the widget as its argument. It doesn't have to +remove the text, but it should release markers and delete nested widgets +if such has been used. + +@item :format-handler +Function to handle unknown @samp{%} escapes in the format string. It +will be called with the widget and the escape character as arguments. +You can set this to allow your widget to handle non-standard escapes. + +You should end up calling @code{widget-default-format-handler} to handle +unknown escape sequences, which will handle the @samp{%h} and any future +escape sequences, as well as give an error for unknown escapes. +@end table + +If you want to define a new widget from scratch, use the @code{default} +widget as its base. + +@deffn Widget default [ keyword argument ] +Widget used as a base for other widgets. + +It provides most of the functionality that is referred to as ``by +default'' in this text. +@end deffn + +@node Widget Wishlist., , Defining New Widgets, Top +@comment node-name, next, previous, up +@section Wishlist. + +@itemize @bullet +@item +It should be possible to add or remove items from a list with @kbd{C-k} +and @kbd{C-o} (suggested by @sc{rms}). + +@item +The @samp{[INS]} and @samp{[DEL]} buttons should be replaced by a single +dash (@samp{-}). The dash should be a button that, when activated, ask +whether you want to add or delete an item (@sc{rms} wanted to git rid of +the ugly buttons, the dash is my idea). + +@item +Widgets such as @code{file} and @code{symbol} should prompt with completion. + +@item +The @code{menu-choice} tag should be prettier, something like the abbreviated +menus in Open Look. + +@item +The functions used in many widgets, like +@code{widget-item-convert-widget}, should not have names that are +specific to the first widget where I happended to use them. + +@item +Unchecked items in a @code{radio-button-choice} or @code{checklist} +should be grayed out, and the subwidgets should somehow become inactive. +This could perhaps be implemented by binding @code{widget-inactive} to t +when inserting the grayed out subwidget, and let the widget-specify +functions check that variable. + +@item +Flag to make @code{widget-move} skip a specified button. + +@item +Document `helper' functions for defining new widgets. + +@item +Activate the item this is below the mouse when the button is +released, not the item this is below the mouse when the button is +pressed. Dired and grep gets this right. Give feedback if possible. + +@item +Use @samp{@@deffn Widget} to document widgets. + +@item +Document global keywords in one place. + +Document keywords particular to a specific widget in the widget +definition. + +Document the `default' widget first. + +Split, when needed, keywords into those useful for normal +customization, those primarily useful when deriving, and those who +represent runtime information. + +@item +Figure out terminology and @sc{api} for the class/type/object/super +stuff. + +Perhaps the correct model is delegation? + +@item +Document @code{widget-browse}. + +@item +Make indentation work with glyphs and propertional fonts. + +@item +Add object and class hierarchies to the browser. + +@end itemize + +@contents +@bye diff -r 498bf5da1c90 -r 0d2f883870bc man/xemacs-faq.texi --- a/man/xemacs-faq.texi Mon Aug 13 09:12:43 2007 +0200 +++ b/man/xemacs-faq.texi Mon Aug 13 09:13:56 2007 +0200 @@ -10,7 +10,7 @@ @subtitle Frequently asked questions about XEmacs @subtitle Last Modified: 1997/01/16 @sp 1 -@author Anthony Rossini <arossini@@biostats.hmc.psu.edu> +@author Tony Rossini <arossini@@stat.sc.edu> @author Ben Wing <wing@@netcom.com> @author Chuck Thompson <cthomp@@cs.uiuc.edu> @author Steve Baur <steve@@miranova.com> diff -r 498bf5da1c90 -r 0d2f883870bc src/ChangeLog --- a/src/ChangeLog Mon Aug 13 09:12:43 2007 +0200 +++ b/src/ChangeLog Mon Aug 13 09:13:56 2007 +0200 @@ -1,3 +1,26 @@ +Sat Feb 15 02:30:51 1997 Steven L Baur <steve@altair.xemacs.org> + + * cmds.c: Define new symbol signal-error-on-buffer-boundary. + (Fforward_char): Use it. + (Fbackward_char): Use it. + + * window.c (Fscroll_up): Use it. + (Fscroll_down): Use it. + + * keymap.c (syms_of_keymap): define mouse-[123] and + down-mouse-[123] pseudo-keysym aliases for Emacs compatibility. + +Thu Feb 13 21:28:35 1997 Steven L Baur <steve@altair.xemacs.org> + + * Makefile.in.in: Don't dump tm with XEmacs under any + circumstances. + + * puresize.h: Remove extra SunPro puresize for MULE+tm. + +Sun Feb 9 04:40:36 1997 Axel Seibert <aseibert@cybernet-ag.net> + + * emacs.c (main_1): Fix NeXT malloc initialization. + Fri Feb 7 11:36:56 1997 Steven L Baur <steve@altair.xemacs.org> * mule-coding.c (Fdecode_coding_region): Make explicit call to diff -r 498bf5da1c90 -r 0d2f883870bc src/Makefile.in.in --- a/src/Makefile.in.in Mon Aug 13 09:12:43 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 09:13:56 2007 +0200 @@ -320,7 +320,7 @@ # define SOUND_CFLAGS +e -I/usr/audio/examples # endif /* USE_GCC */ # define SOUND_OBJS hpplay.o -# elif defined (LINUX) +# elif defined (LINUX) || defined(__FreeBSD__) # define SOUND_CFLAGS # define SOUND_OBJS linuxplay.o # else @@ -562,9 +562,11 @@ # ifdef HAVE_WNN # define WNN_OBJS mule-wnnfns.o # define WNN_OBJ_SRC ${muledirfromsrc}/mule-wnnfns.c +# define LIB_WNN -lwnn # else # define WNN_OBJS # define WNN_OBJ_SRC +# define LIB_WNN # endif /* Chuck says that you have to have at least one specified actual object file per line. */ @@ -580,6 +582,7 @@ mule_objs= mule_obj_src= #define LIB_CANNA +#define LIB_WNN #endif /* not MULE */ @@ -627,9 +630,13 @@ LIBX11_LIBS = -llw $(TOOLKIT_LIBS) $(XPM_LIBS) $(XFACE_LIBS) $(JPEG_LIBS) $(PNG_LIBS) $(USAGE_TRACKING_LIBS) #ifdef AIX4 -#define LIBI18N -li18n +# define LIBI18N -li18n #else -#define LIBI18N +# if (defined(LINUX) && defined(HAVE_CDE)) +# define LIBI18N -lXintl +# else +# define LIBI18N +#endif /* LINUX & CDE */ #endif /* AIX4 */ #ifdef THIS_IS_X11R6 @@ -788,7 +795,7 @@ #ifdef TOOLTALK # define TOOLTALK_OBJS tooltalk.o -# if (defined (IRIX5) || defined (HPUX) || defined (POWERPC) || defined (AIX4)) +# if (defined (IRIX5) || defined (HPUX) || defined (POWERPC) || defined (AIX4) || defined (LINUX)) # define LIB_TOOLTALK -ltt # else # if (defined (SPARC) && !defined (USG)) @@ -1152,19 +1159,6 @@ #ifdef SUNPRO /* Lisp files preloaded if compiled with support for SunPro products */ -#define MULE_TM_LISP \ - ${lispdir}tm/mime-setup.elc \ - ${lispdir}tl/tl-misc.elc \ - ${lispdir}tl/tl-str.elc \ - ${lispdir}tl/tl-list.elc \ - ${lispdir}tl/tl-seq.elc \ - ${lispdir}tl/tl-atype.elc \ - ${lispdir}tl/file-detect.elc \ - ${lispdir}tl/emu.elc \ - ${lispdir}tl/emu-x20.elc \ - ${lispdir}tl/emu-xemacs.elc \ - ${lispdir}tm/tm-setup.elc \ - ${lispdir}mule/cyrillic.elc #define SUNPRO_LISP \ ${lispdir}packages/sccs.elc \ ${lispdir}sunpro/sunpro-init.elc \ @@ -1184,8 +1178,7 @@ ${lispdir}utils/annotations.elc \ ${lispdir}modes/cc-mode.elc \ ${lispdir}modes/imenu.elc \ - ${lispdir}utils/reporter.elc \ - MULE_TM_LISP + ${lispdir}utils/reporter.elc #else #define SUNPRO_LISP #endif @@ -1275,6 +1268,8 @@ ${lispdir}modes/auto-show.elc SUNPRO_LISP TTY_LISP \ ${lispdir}bytecomp/bytecomp-runtime.elc FLOAT_LISP EPOCH_LISP \ ${lispdir}prim/itimer.elc ${lispdir}ediff/ediff-hook.elc \ + ${lispdir}custom/custom.elc ${lispdir}custom/widget.elc \ + ${lispdir}w3/font.elc \ ${lispdir}packages/fontl-hooks.elc SCROLLBAR_LISP \ ${lispdir}prim/buffer.elc MENUBAR_LISP \ ${lispdir}packages/buff-menu.elc DIALOG_LISP MULE_LISP NOMULE_LISP \ @@ -1291,7 +1286,7 @@ LIBES = NAS_LIBS ${native_sound_lib} SOCKS_LIBS ENERGIZE_LIBS LIB_CDE LIB_OFFIX_DND \ LIB_TOOLTALK $(LIBX) \ LIBS_SYSTEM LIBS_MACHINE LIBS_TERMCAP \ - LIB_CANNA LIB_INTL QUANTIFY_LIBS $(LIB_KSTAT) \ + LIB_CANNA LIB_WNN LIB_INTL QUANTIFY_LIBS $(LIB_KSTAT) \ DATABASE_LIBS LIBS_DEBUG $(GNULIB_VAR) LIB_MATH LIB_STANDARD \ $(GNULIB_VAR) diff -r 498bf5da1c90 -r 0d2f883870bc src/buffer.c --- a/src/buffer.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/buffer.c Mon Aug 13 09:13:56 2007 +0200 @@ -1775,7 +1775,7 @@ int gap; was_requested = b->text->z - 1; - gap = b->text->gap_size; + gap = b->text->gap_size + b->text->end_gap_size; malloc_use = malloced_storage_size (b->text->beg, was_requested + gap, 0); ovstats->gap_overhead += gap; ovstats->was_requested += was_requested; diff -r 498bf5da1c90 -r 0d2f883870bc src/buffer.h --- a/src/buffer.h Mon Aug 13 09:12:43 2007 +0200 +++ b/src/buffer.h Mon Aug 13 09:13:56 2007 +0200 @@ -81,6 +81,7 @@ Bytind z; /* Index of end of buffer. */ Bufpos bufz; /* Equivalent as a Bufpos. */ int gap_size; /* Size of buffer's gap */ + int end_gap_size; /* Size of buffer's end gap */ int modiff; /* This counts buffer-modification events for this buffer. It is incremented for each such event, and never otherwise diff -r 498bf5da1c90 -r 0d2f883870bc src/cmds.c --- a/src/cmds.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/cmds.c Mon Aug 13 09:13:56 2007 +0200 @@ -41,11 +41,15 @@ /* This is the command that set up Vself_insert_face. */ Lisp_Object Vself_insert_face_command; +/* t means beep when movement would take point past (point-min) or */ +/* (point-max) */ +int signal_error_on_buffer_boundary; DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /* Move point right ARG characters (left if ARG negative). On reaching end of buffer, stop and signal error. -If BUFFER is nil, the current buffer is assumed. +Error signaling is suppressed if `signal-error-on-buffer-boundary' +is nil. If BUFFER is nil, the current buffer is assumed. */ (arg, buffer)) { @@ -67,12 +71,18 @@ if (new_point < BUF_BEGV (buf)) { BUF_SET_PT (buf, BUF_BEGV (buf)); - Fsignal (Qbeginning_of_buffer, Qnil); + if (signal_error_on_buffer_boundary) + Fsignal (Qbeginning_of_buffer, Qnil); + else + return Qnil; } if (new_point > BUF_ZV (buf)) { BUF_SET_PT (buf, BUF_ZV (buf)); - Fsignal (Qend_of_buffer, Qnil); + if (signal_error_on_buffer_boundary) + Fsignal (Qend_of_buffer, Qnil); + else + return Qnil; } BUF_SET_PT (buf, new_point); @@ -84,7 +94,8 @@ DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /* Move point left ARG characters (right if ARG negative). On attempt to pass beginning or end of buffer, stop and signal error. -If BUFFER is nil, the current buffer is assumed. +Error signaling is suppressed if `signal-error-on-buffer-boundary' +is nil. If BUFFER is nil, the current buffer is assumed. */ (arg, buffer)) { @@ -479,4 +490,10 @@ More precisely, a char with closeparen syntax is self-inserted. */ ); Vblink_paren_function = Qnil; + + DEFVAR_BOOL ("signal-error-on-buffer-boundary", &signal_error_on_buffer_boundary /* +t means beep when movement would take point past (point-min) or +\(point-max). +*/ ); + signal_error_on_buffer_boundary = 1; } diff -r 498bf5da1c90 -r 0d2f883870bc src/config.h.in --- a/src/config.h.in Mon Aug 13 09:12:43 2007 +0200 +++ b/src/config.h.in Mon Aug 13 09:13:56 2007 +0200 @@ -390,6 +390,7 @@ /* Non-XIM input methods for use with Mule. */ #undef HAVE_CANNA #undef HAVE_WNN +#undef WNN6 /* Mocklisp Support. */ #undef MOCKLISP_SUPPORT diff -r 498bf5da1c90 -r 0d2f883870bc src/emacs.c --- a/src/emacs.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/emacs.c Mon Aug 13 09:13:56 2007 +0200 @@ -446,6 +446,9 @@ int skip_args = 0; Lisp_Object load_me; int inhibit_window_system; +#ifdef NeXT + extern int malloc_cookie; +#endif #ifndef SYSTEM_MALLOC /* Make sure that any libraries we link against haven't installed a @@ -458,8 +461,6 @@ noninteractive = 0; #ifdef NeXT - extern int malloc_cookie; - /* 19-Jun-1995 -baw * NeXT secret magic, ripped from Emacs-for-NS by Carl Edman * <cedman@princeton.edu>. Note that even Carl doesn't know what this diff -r 498bf5da1c90 -r 0d2f883870bc src/event-stream.c --- a/src/event-stream.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/event-stream.c Mon Aug 13 09:13:56 2007 +0200 @@ -1679,7 +1679,7 @@ Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d); /* You'd think that maybe we should use FRAME_WITH_FOCUS_REAL, - but that can cause us to end up in an infinite loop focussing + but that can cause us to end up in an infinite loop focusing between two frames. It seems that since the call to `select-frame' in emacs_handle_focus_change_final() is based on the _FOR_HOOKS value, we need to do so too. */ @@ -3912,7 +3912,7 @@ function is treated like any other character, and `quit-flag' is not set. First arg PROMPT is a prompt string. If nil, do not prompt specially. -Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echos +Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echoes as a continuation of the previous key. The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not @@ -4369,7 +4369,7 @@ When it is read, do `(eval help-form)', and display result if it's a string. If the value of `help-form' is nil, this char can be read normally. This can be any form recognized as a single key specifier. -To disable the help-char, set it to a negative number. +The help-char cannot be a negative number in XEmacs. */ ); Vhelp_char = make_char (8); /* C-h */ diff -r 498bf5da1c90 -r 0d2f883870bc src/extents.c --- a/src/extents.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/extents.c Mon Aug 13 09:13:56 2007 +0200 @@ -2380,10 +2380,13 @@ void adjust_extents_for_deletion (Lisp_Object object, Bytind from, - Bytind to, int gapsize, int numdel) + Bytind to, int gapsize, int numdel, + int movegapsize) { struct adjust_extents_for_deletion_arg closure; int i; + Memind adjust_to = (Memind) (to + gapsize); + Bytecount amount = - numdel - movegapsize; Memind oldsoe, newsoe; Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (object); @@ -2414,9 +2417,8 @@ oldsoe = soe->pos; if (soe->pos >= 0) newsoe = do_marker_adjustment (soe->pos, - (Memind) (to + gapsize), - (Memind) (to + gapsize), - - numdel - gapsize); + adjust_to, adjust_to, + amount); else newsoe = soe->pos; } @@ -2424,21 +2426,20 @@ for (i = 0; i < Dynarr_length (closure.list); i++) { EXTENT extent = Dynarr_at (closure.list, i); - Memind new_start, new_end; + Memind new_start = extent_start (extent); + Memind new_end = extent_end (extent); /* do_marker_adjustment() will not adjust values that should not be adjusted. We're passing the same funky arguments to do_marker_adjustment() as buffer_delete_range() does. */ new_start = - do_marker_adjustment (extent_start (extent), - (Memind) (to + gapsize), - (Memind) (to + gapsize), - - numdel - gapsize); + do_marker_adjustment (new_start, + adjust_to, adjust_to, + amount); new_end = - do_marker_adjustment (extent_end (extent), - (Memind) (to + gapsize), - (Memind) (to + gapsize), - - numdel - gapsize); + do_marker_adjustment (new_end, + adjust_to, adjust_to, + amount); /* We need to be very careful here so that the SOE doesn't get corrupted. We are shrinking extents out of the deleted region @@ -5138,7 +5139,8 @@ `inside-margin', or `outside-margin') of the extent's begin glyph. - end-glyph-layout The layout policy of the extent's end glyph. */ + end-glyph-layout The layout policy of the extent's end glyph. +*/ (extent, property, value)) { /* This function can GC if property is `keymap' */ @@ -6354,9 +6356,15 @@ if (NILP (prop)) signal_simple_error ("internal error: no text-prop", extent); val = Fextent_property (extent, prop, Qnil); +#if 0 + /* removed by bill perry, 2/9/97 + ** This little bit of code would not allow you to have a text property + ** with a value of Qnil. This is bad bad bad. + */ if (NILP (val)) signal_simple_error_2 ("internal error: no text-prop", extent, prop); +#endif Fput_text_property (from, to, prop, val, Qnil); return Qnil; /* important! */ } diff -r 498bf5da1c90 -r 0d2f883870bc src/extents.h --- a/src/extents.h Mon Aug 13 09:12:43 2007 +0200 +++ b/src/extents.h Mon Aug 13 09:13:56 2007 +0200 @@ -369,7 +369,7 @@ Memind to, int amount); void adjust_extents_for_deletion (Lisp_Object object, Bytind from, Bytind to, int gapsize, - int numdel); + int numdel, int movegapsize); void verify_extent_modification (Lisp_Object object, Bytind from, Bytind to, Lisp_Object inhibit_read_only_value); diff -r 498bf5da1c90 -r 0d2f883870bc src/frame.c --- a/src/frame.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/frame.c Mon Aug 13 09:13:56 2007 +0200 @@ -460,7 +460,10 @@ the frame-specific version of the buffer-alist unless the frame is accessible from the device. */ +#if 0 DEVICE_FRAME_LIST (d) = nconc2 (DEVICE_FRAME_LIST (d), Fcons (frame, Qnil)); +#endif + DEVICE_FRAME_LIST (d) = Fcons (frame, DEVICE_FRAME_LIST (d)); RESET_CHANGED_SET_FLAGS; /* Now make sure that the initial cached values are set correctly. diff -r 498bf5da1c90 -r 0d2f883870bc src/glyphs-x.c --- a/src/glyphs-x.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/glyphs-x.c Mon Aug 13 09:13:56 2007 +0200 @@ -1054,6 +1054,7 @@ /* The in-core jpeg code doesn't work, so I'm avoiding it for now. -sb */ #define USE_TEMP_FILES_FOR_JPEG_IMAGES 1 +#define USE_TEMP_FILES_FOR_PNG_IMAGES 1 static void jpeg_validate (Lisp_Object instantiator) @@ -1875,7 +1876,7 @@ return IMAGE_COLOR_PIXMAP_MASK; } -#if !defined (USE_TEMP_FILES_FOR_IMAGES) && (PNG_LIBPNG_VER >= 87) +#if !defined (USE_TEMP_FILES_FOR_PNG_IMAGES) && (PNG_LIBPNG_VER >= 87) struct png_memory_storage { Extbyte *bytes; /* The data */ @@ -1894,7 +1895,7 @@ memcpy(data,tbr->bytes + tbr->index,length); tbr->index = tbr->index + length; } -#endif /* !USE_TEMP_FILES_FOR_IMAGESS || PNG_LIBPNG_VER >= 87 */ +#endif /* !USE_TEMP_FILES_FOR_PNG_IMAGESS || PNG_LIBPNG_VER >= 87 */ struct png_unwind_data { @@ -1996,7 +1997,7 @@ this file, example.c from the libpng 0.81 distribution, and the pngtopnm sources. -WMP- */ -#if defined (USE_TEMP_FILES_FOR_IMAGES) || (PNG_LIBPNG_VER < 87) +#if defined (USE_TEMP_FILES_FOR_PNG_IMAGES) || (PNG_LIBPNG_VER < 87) /* Write out to a temp file - we really should take the time to write appropriate memory bound IO stuff, but I am just trying to get the stupid thing working right now. @@ -2032,7 +2033,7 @@ png_read_init (png_ptr); /* Initialize the IO layer and read in header information */ -#if defined (USE_TEMP_FILES_FOR_IMAGES) || (PNG_LIBPNG_VER < 87) +#if defined (USE_TEMP_FILES_FOR_PNG_IMAGES) || (PNG_LIBPNG_VER < 87) png_init_io (png_ptr, unwind.instream); #else { diff -r 498bf5da1c90 -r 0d2f883870bc src/input-method-motif.c --- a/src/input-method-motif.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/input-method-motif.c Mon Aug 13 09:13:56 2007 +0200 @@ -32,6 +32,10 @@ #include "EmacsFrame.h" #include <Xm/Xm.h> +#ifdef __FreeBSD__ +#include <osreldate.h> +#endif + #ifndef XIM_MOTIF #error XIM_MOTIF is not defined?? #endif @@ -42,7 +46,15 @@ char *locale; XtSetLanguageProc (NULL, (XtLanguageProc) NULL, NULL); +#ifdef __FreeBSD_version +# if __FreeBSD_version >= 199701 + if ((locale = setlocale (LC_CTYPE, "")) == NULL) +# else if ((locale = setlocale (LC_ALL, "")) == NULL) +# endif +#else + if ((locale = setlocale (LC_ALL, "")) == NULL) +#endif { stderr_out ("Can't set locale.\n"); stderr_out ("Using C locale instead.\n"); diff -r 498bf5da1c90 -r 0d2f883870bc src/insdel.c --- a/src/insdel.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/insdel.c Mon Aug 13 09:13:56 2007 +0200 @@ -232,10 +232,12 @@ /* Gap size. */ #define BUF_GAP_SIZE(buf) ((buf)->text->gap_size + 0) - +#define BUF_END_GAP_SIZE(buf) ((buf)->text->end_gap_size + 0) /* Set gap size. */ #define SET_BUF_GAP_SIZE(buf, value) \ do { (buf)->text->gap_size = (value); } while (0) +#define SET_BUF_END_GAP_SIZE(buf, value) \ + do { (buf)->text->end_gap_size = (value); } while (0) /* Gap location. */ #define BI_BUF_GPT(buf) ((buf)->text->gpt + 0) @@ -1801,6 +1803,15 @@ sledgehammer_extent_check (make_buffer (buf)); #endif } + if (pos == BI_BUF_Z (buf)) + { + /* merge gap with end gap */ + + SET_BUF_GAP_SIZE (buf, BUF_GAP_SIZE (buf) + BUF_END_GAP_SIZE (buf)); + SET_BUF_END_GAP_SIZE (buf, 0); + SET_END_SENTINEL (buf); + } + QUIT; } @@ -1818,6 +1829,49 @@ gap_right (buf, pos); } +/* Merge the end gap into the gap */ + +static void +merge_gap_with_end_gap (struct buffer *buf) +{ + Lisp_Object tem; + Bytind real_gap_loc; + Bytecount old_gap_size; + Bytecount increment; + + increment = BUF_END_GAP_SIZE (buf); + SET_BUF_END_GAP_SIZE (buf, 0); + + if (increment > 0) + { + /* Prevent quitting in move_gap. */ + tem = Vinhibit_quit; + Vinhibit_quit = Qt; + + real_gap_loc = BI_BUF_GPT (buf); + old_gap_size = BUF_GAP_SIZE (buf); + + /* Pretend the end gap is the gap */ + SET_BI_BUF_GPT (buf, BI_BUF_Z (buf) + BUF_GAP_SIZE (buf)); + SET_BUF_GAP_SIZE (buf, increment); + + /* Move the new gap down to be consecutive with the end of the old one. + This adjusts the markers properly too. */ + gap_left (buf, real_gap_loc + old_gap_size); + + /* Now combine the two into one large gap. */ + SET_BUF_GAP_SIZE (buf, BUF_GAP_SIZE (buf) + old_gap_size); + SET_BI_BUF_GPT (buf, real_gap_loc); + SET_GAP_SENTINEL (buf); + + /* We changed the total size of the buffer (including gap), + so we need to fix up the end sentinel. */ + SET_END_SENTINEL (buf); + + Vinhibit_quit = tem; + } +} + /* Make the gap INCREMENT bytes longer. */ static void @@ -1832,22 +1886,28 @@ a geometric progession that saves on realloc space. */ increment += 2000 + ((BI_BUF_Z (buf) - BI_BUF_BEG (buf)) / 8); - /* Don't allow a buffer size that won't fit in an int - even if it will fit in a Lisp integer. - That won't work because so many places use `int'. */ - - if (BUF_Z (buf) - BUF_BEG (buf) + BUF_GAP_SIZE (buf) + increment - >= ((unsigned) 1 << (min (INTBITS, VALBITS) - 1))) - error ("Buffer exceeds maximum size"); - - result = BUFFER_REALLOC (buf->text->beg, - BI_BUF_Z (buf) - BI_BUF_BEG (buf) + - BUF_GAP_SIZE (buf) + increment + - BUF_END_SENTINEL_SIZE); - if (result == 0) - memory_full (); - SET_BUF_BEG_ADDR (buf, result); - + if (increment > BUF_END_GAP_SIZE (buf)) + { + /* Don't allow a buffer size that won't fit in an int + even if it will fit in a Lisp integer. + That won't work because so many places use `int'. */ + + if (BUF_Z (buf) - BUF_BEG (buf) + BUF_GAP_SIZE (buf) + increment + >= ((unsigned) 1 << (min (INTBITS, VALBITS) - 1))) + error ("Buffer exceeds maximum size"); + + result = BUFFER_REALLOC (buf->text->beg, + BI_BUF_Z (buf) - BI_BUF_BEG (buf) + + BUF_GAP_SIZE (buf) + increment + + BUF_END_SENTINEL_SIZE); + if (result == 0) + memory_full (); + + SET_BUF_BEG_ADDR (buf, result); + } + else + increment = BUF_END_GAP_SIZE (buf); + /* Prevent quitting in move_gap. */ tem = Vinhibit_quit; Vinhibit_quit = Qt; @@ -1859,6 +1919,8 @@ SET_BI_BUF_GPT (buf, BI_BUF_Z (buf) + BUF_GAP_SIZE (buf)); SET_BUF_GAP_SIZE (buf, increment); + SET_BUF_END_GAP_SIZE (buf, 0); + /* Move the new gap down to be consecutive with the end of the old one. This adjusts the markers properly too. */ gap_left (buf, real_gap_loc + old_gap_size); @@ -2375,7 +2437,12 @@ in Emacs. */ move_gap (buf, ind); /* may QUIT */ if (! GAP_CAN_HOLD_SIZE_P (buf, length)) - make_gap (buf, length - BUF_GAP_SIZE (buf)); + { + if (BUF_END_GAP_SIZE (buf) >= length) + merge_gap_with_end_gap (buf); + else + make_gap (buf, length - BUF_GAP_SIZE (buf)); + } record_insert (buf, pos, cclen); BUF_MODIFF (buf)++; @@ -2564,50 +2631,96 @@ bi_to = bufpos_to_bytind (buf, to); bc_numdel = bi_to - bi_from; - /* Make sure the gap is somewhere in or next to what we are deleting. */ - if (bi_to < BI_BUF_GPT (buf)) - gap_left (buf, bi_to); - if (bi_from > BI_BUF_GPT (buf)) - gap_right (buf, bi_from); - - record_delete (buf, from, numdel); - BUF_MODIFF (buf)++; - MARK_BUFFERS_CHANGED; - - /* Relocate point as if it were a marker. */ - if (bi_from < BI_BUF_PT (buf)) + if (to == BUF_Z (buf) && + bi_from > BI_BUF_GPT (buf)) { - if (BI_BUF_PT (buf) < bi_to) - JUST_SET_POINT (buf, from, bi_from); - else - JUST_SET_POINT (buf, BUF_PT (buf) - numdel, - BI_BUF_PT (buf) - bc_numdel); + /* avoid moving the gap just to delete from the bottom. */ + + record_delete (buf, from, numdel); + BUF_MODIFF (buf)++; + MARK_BUFFERS_CHANGED; + + /* Relocate point as if it were a marker. */ + if (bi_from < BI_BUF_PT (buf)) + { + if (BI_BUF_PT (buf) < bi_to) + JUST_SET_POINT (buf, from, bi_from); + else + JUST_SET_POINT (buf, BUF_PT (buf) - numdel, + BI_BUF_PT (buf) - bc_numdel); + } + + /* Detach any extents that are completely within the range [FROM, TO], + if the extents are detachable. + + This must come AFTER record_delete(), so that the appropriate extents + will be present to be recorded, and BEFORE the gap size is increased, + as otherwise we will be confused about where the extents end. */ + process_extents_for_deletion (bufobj, bi_from, bi_to, 0); + + /* Relocate all markers pointing into the new, larger gap + to point at the end of the text before the gap. */ + adjust_markers (buf, + (bi_to + BUF_GAP_SIZE (buf)), + (bi_to + BUF_GAP_SIZE (buf)), + (- bc_numdel)); + + /* Relocate any extent endpoints just like markers. */ + adjust_extents_for_deletion (bufobj, bi_from, bi_to, + BUF_GAP_SIZE (buf), bc_numdel, 0); + SET_BUF_END_GAP_SIZE (buf, BUF_END_GAP_SIZE (buf) + bc_numdel); + + SET_BOTH_BUF_ZV (buf, BUF_ZV (buf) - numdel, BI_BUF_ZV (buf) - bc_numdel); + SET_BOTH_BUF_Z (buf, BUF_Z (buf) - numdel, BI_BUF_Z (buf) - bc_numdel); + SET_GAP_SENTINEL (buf); } - - /* Detach any extents that are completely within the range [FROM, TO], - if the extents are detachable. - - This must come AFTER record_delete(), so that the appropriate extents - will be present to be recorded, and BEFORE the gap size is increased, - as otherwise we will be confused about where the extents end. */ - process_extents_for_deletion (bufobj, bi_from, bi_to, 0); - - /* Relocate all markers pointing into the new, larger gap - to point at the end of the text before the gap. */ - adjust_markers (buf, - (bi_to + BUF_GAP_SIZE (buf)), - (bi_to + BUF_GAP_SIZE (buf)), - (- bc_numdel - BUF_GAP_SIZE (buf))); - - /* Relocate any extent endpoints just like markers. */ - adjust_extents_for_deletion (bufobj, bi_from, bi_to, BUF_GAP_SIZE (buf), - bc_numdel); - - SET_BUF_GAP_SIZE (buf, BUF_GAP_SIZE (buf) + bc_numdel); - SET_BOTH_BUF_ZV (buf, BUF_ZV (buf) - numdel, BI_BUF_ZV (buf) - bc_numdel); - SET_BOTH_BUF_Z (buf, BUF_Z (buf) - numdel, BI_BUF_Z (buf) - bc_numdel); - SET_BI_BUF_GPT (buf, bi_from); - SET_GAP_SENTINEL (buf); + else + { + /* Make sure the gap is somewhere in or next to what we are deleting. */ + if (bi_to < BI_BUF_GPT (buf)) + gap_left (buf, bi_to); + if (bi_from > BI_BUF_GPT (buf)) + gap_right (buf, bi_from); + + record_delete (buf, from, numdel); + BUF_MODIFF (buf)++; + MARK_BUFFERS_CHANGED; + + /* Relocate point as if it were a marker. */ + if (bi_from < BI_BUF_PT (buf)) + { + if (BI_BUF_PT (buf) < bi_to) + JUST_SET_POINT (buf, from, bi_from); + else + JUST_SET_POINT (buf, BUF_PT (buf) - numdel, + BI_BUF_PT (buf) - bc_numdel); + } + + /* Detach any extents that are completely within the range [FROM, TO], + if the extents are detachable. + + This must come AFTER record_delete(), so that the appropriate extents + will be present to be recorded, and BEFORE the gap size is increased, + as otherwise we will be confused about where the extents end. */ + process_extents_for_deletion (bufobj, bi_from, bi_to, 0); + + /* Relocate all markers pointing into the new, larger gap + to point at the end of the text before the gap. */ + adjust_markers (buf, + (bi_to + BUF_GAP_SIZE (buf)), + (bi_to + BUF_GAP_SIZE (buf)), + (- bc_numdel - BUF_GAP_SIZE (buf))); + + /* Relocate any extent endpoints just like markers. */ + adjust_extents_for_deletion (bufobj, bi_from, bi_to, BUF_GAP_SIZE (buf), + bc_numdel, BUF_GAP_SIZE (buf)); + + SET_BUF_GAP_SIZE (buf, BUF_GAP_SIZE (buf) + bc_numdel); + SET_BOTH_BUF_ZV (buf, BUF_ZV (buf) - numdel, BI_BUF_ZV (buf) - bc_numdel); + SET_BOTH_BUF_Z (buf, BUF_Z (buf) - numdel, BI_BUF_Z (buf) - bc_numdel); + SET_BI_BUF_GPT (buf, bi_from); + SET_GAP_SENTINEL (buf); + } #ifdef MULE buffer_mule_signal_deleted_region (buf, from, to, bi_from, bi_to); @@ -2957,7 +3070,8 @@ BUF_GAP_SIZE (b) + BUF_END_SENTINEL_SIZE); if (! BUF_BEG_ADDR (b)) memory_full (); - + + SET_BUF_END_GAP_SIZE (b, 0); SET_BI_BUF_GPT (b, 1); SET_BOTH_BUF_Z (b, 1, 1); SET_GAP_SENTINEL (b); diff -r 498bf5da1c90 -r 0d2f883870bc src/keymap.c --- a/src/keymap.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/keymap.c Mon Aug 13 09:13:56 2007 +0200 @@ -227,6 +227,9 @@ Lisp_Object Qbutton0up, Qbutton1up, Qbutton2up, Qbutton3up, Qbutton4up, Qbutton5up, Qbutton6up, Qbutton7up; Lisp_Object Qmenu_selection; +/* Emacs compatibility */ +Lisp_Object Qdown_mouse_1, Qdown_mouse_2, Qdown_mouse_3; +Lisp_Object Qmouse_1, Qmouse_2, Qmouse_3; /* Kludge kludge kludge */ Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS; @@ -1342,6 +1345,19 @@ *keysym = QKdelete; else if (EQ (*keysym, QBS)) *keysym = QKbackspace; + /* Emacs compatibility */ + else if (EQ(*keysym, Qdown_mouse_1)) + *keysym = Qbutton1; + else if (EQ(*keysym, Qdown_mouse_2)) + *keysym = Qbutton2; + else if (EQ(*keysym, Qdown_mouse_3)) + *keysym = Qbutton3; + else if (EQ(*keysym, Qmouse_1)) + *keysym = Qbutton1up; + else if (EQ(*keysym, Qmouse_2)) + *keysym = Qbutton2up; + else if (EQ(*keysym, Qmouse_3)) + *keysym = Qbutton3up; } } @@ -4198,6 +4214,12 @@ defsymbol (&Qbutton5up, "button5up"); defsymbol (&Qbutton6up, "button6up"); defsymbol (&Qbutton7up, "button7up"); + defsymbol (&Qmouse_1, "mouse-1"); + defsymbol (&Qmouse_2, "mouse-2"); + defsymbol (&Qmouse_3, "mouse-3"); + defsymbol (&Qdown_mouse_1, "down-mouse-1"); + defsymbol (&Qdown_mouse_2, "down-mouse-2"); + defsymbol (&Qdown_mouse_3, "down-mouse-3"); defsymbol (&Qmenu_selection, "menu-selection"); defsymbol (&QLFD, "LFD"); defsymbol (&QTAB, "TAB"); diff -r 498bf5da1c90 -r 0d2f883870bc src/linuxplay.c --- a/src/linuxplay.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/linuxplay.c Mon Aug 13 09:13:56 2007 +0200 @@ -61,7 +61,11 @@ #include <errno.h> #include <fcntl.h> -#include <linux/soundcard.h> +#ifdef __FreeBSD__ +# include <machine/soundcard.h> +#else +# include <linux/soundcard.h> +#endif #include <stdio.h> #include <stdlib.h> #include <string.h> @@ -88,8 +92,8 @@ #define __inline__ #endif -static __sighandler_t sighup_handler; -static __sighandler_t sigint_handler; +static void (*sighup_handler)(int); +static void (*sigint_handler)(int); /* Maintain global variable for keeping parser state information; this struct is set to zero before the first invocation of the parser. The use of a @@ -982,8 +986,8 @@ this could lead to problems, when multiple sound cards are installed */ mix_fd = audio_fd; - sighup_handler = signal(SIGHUP,(__sighandler_t)sighandler); - sigint_handler = signal(SIGINT,(__sighandler_t)sighandler); + sighup_handler = signal(SIGHUP, sighandler); + sigint_handler = signal(SIGINT, sighandler); if (!audio_init(mix_fd,audio_fd,fmt,speed,tracks,&volume,&sndcnv)) goto END_OF_PLAY; diff -r 498bf5da1c90 -r 0d2f883870bc src/mule-canna.c --- a/src/mule-canna.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/mule-canna.c Mon Aug 13 09:13:56 2007 +0200 @@ -28,7 +28,7 @@ /* - Authors: Akira Kon (kon@d1.bs2.mt.nec.co.jp) + Authors: Akira Kon (we need a current email address) Ichiro Hirakura (hirakura@uxp.bs2.mt.nec.co.jp) Functions defined in this file are @@ -212,7 +212,7 @@ jrKanjiStatus ks; int len; - CHECK_CHAR (ch); + CHECK_CHAR_COERCE_INT (ch); len = jrKanjiString (0, XCHAR (ch), buf, KEYTOSTRSIZE, &ks); return storeResults (buf, len, &ks); } @@ -323,6 +323,14 @@ jrKanjiControl (0, KC_SETBUNSETSUKUGIRI, (char *) kugiri); } +/* For whatever reason, calling Fding directly from libCanna loses */ +static void call_Fding() +{ + extern Lisp_Object Fding(); + + (void)Fding(Qnil, Qnil, Qnil); +} + DEFUN ("canna-initialize", Fcanna_initialize, 0, 3, 0, /* Initialize ``canna'', which is a kana-to-kanji converter for GNU Emacs. The first arg specifies if inserting space character between BUNSETSU when @@ -411,10 +419,10 @@ } else { - extern (*jrBeepFunc)(); - Lisp_Object Fding (), CANNA_mode_keys (); + extern void (*jrBeepFunc)(); + Lisp_Object CANNA_mode_keys (); - jrBeepFunc = Fding; + jrBeepFunc = call_Fding; #ifdef KC_SETAPPNAME #ifndef CANNA_MULE @@ -823,12 +831,17 @@ */ (bun, kouho)) { + int nbun, nkouho; + if (confirmContext () == 0) { return Qnil; } - RkGoTo (IRCP_context, bun); - RkXfer (IRCP_context, kouho); + nbun = XINT(bun); + RkGoTo (IRCP_context, nbun); + + nkouho = XINT(kouho); + RkXfer (IRCP_context, nkouho); return Qt; } diff -r 498bf5da1c90 -r 0d2f883870bc src/mule-wnnfns.c --- a/src/mule-wnnfns.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/mule-wnnfns.c Mon Aug 13 09:13:56 2007 +0200 @@ -53,20 +53,20 @@ * pw1: STRING or NIL * pw2: STRING or NIL * DESCRIPTION: - * $B<-=q09:37:18!%$%kL>!"IQEY09:37:18!%$%kL>!"M%@hEY!"<-=q09:37:18!%$%k%b!<%(BI - * $BIQEY09:37:18!%$%k%b!<%I$G;XDj$7$?<-=q$r/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!$KDI2C$9$k!(B# - * pw1, pw2 $B$O<-=q09:37:18!%$%k!"IQEY09:37:18!%$%k$N9%o!<%I!(B# + * $B<-=q%U%!%$%kL>!"IQEY%U%!%$%kL>!"M%@hEY!"<-=q%U%!%$%k%b!<%I(B + * $BIQEY%U%!%$%k%b!<%I$G;XDj$7$?<-=q$r%P%C%U%!$KDI2C$9$k!#(B + * pw1, pw2 $B$O<-=q%U%!%$%k!"IQEY%U%!%$%k$N%Q%9%o!<%I!#(B * * (wnn-server-dict-delete dic-no) * dic-no: INTEGER * RETURNS: $B%(%i!<$N;~(B nil - * DESCRIPTION: dic-no $B$N<-=qHV9f$N<-=q$r!"/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!$+$i(B + * DESCRIPTION: dic-no $B$N<-=qHV9f$N<-=q$r!"%P%C%U%!$+$i(B * $B:o=|$9$k!#(B * * (wnn-server-dict-list) * RETURNS: ((dic-no1 file-name1 comment1 word-no1 nice1) * (dic-no2 file-name2 comment2 word-no2 nice2)...) - * DESCRIPTION: $B/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!>e$N<-=q$N%j%9%H$rF@$k!#(B + * DESCRIPTION: $B%P%C%U%!>e$N<-=q$N%j%9%H$rF@$k!#(B * * (wnn-server-dict-comment dic-no comment) * RETURNS: $B%(%i!<$N;~(B nil @@ -88,14 +88,14 @@ * RETURNS: offset * DESCRIPTION: * $BJ8@aHV9f$G;XDj$5$l$?J8@a$NA48uJd$r$H$j$@$7(B - * $B!"8=:_$N%*09:37:18;89H$rJV$9!#(B + * $B!"8=:_$N%*%U%;%C%H$rJV$9!#(B * * (wnn-server-get-zenkouho offset) * bunsetu-no: INTEGER * dai: BOOLEAN * RETURNS: list of zenkouho * DESCRIPTION: - * $B%*09:37:18;96H$G;XDj$5$l$?8uJd$rF@$k!#(B + * $B%*%U%;%C%H$G;XDj$5$l$?8uJd$rF@$k!#(B * * (wnn-server-zenkouho-bun) * RETURNS: INTEGER @@ -140,7 +140,7 @@ * RETURNS: (kanji yomi jisho-no serial-no hinsi hindo * ima hyoka daihyoka kangovect) * DESCRIPTION: - * $BJ8@a$N?'!9$J>pJs$rJQ49/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!$+$i$H$j=P$9!#(B + * $BJ8@a$N?'!9$J>pJs$rJQ49%P%C%U%!$+$i$H$j=P$9!#(B * * (wnn-server-henkan-quit) * RETURNS: BOOLEAN @@ -180,21 +180,21 @@ * entry: INTEGER * RETURNS: BOOLEAN * DESCRIPTION: - * $B<-=q$+$i%(%s15(B $BSe(Bp $B1995jHV9f$G<($5$l$kC18l$r:o=|$9$k!(B# + * $B<-=q$+$i%(%s%H%jHV9f$G<($5$l$kC18l$r:o=|$9$k!#(B * * (wnn-server-word-use dic-no entry) * dic-no: INTEGER * entry: INTEGER * RETURNS: BOOLEAN * DESCRIPTION: - * $B<-=q$+$i%(%s15(B $BSe(Bp $B1995jHV9f$G<($5$l$kC18l$NM-8z!?L58z$r1(B5 $BSe(Bp $B19950%k$9$k!(B# - * + * $B<-=q$+$i%(%s%H%jHV9f$G<($5$l$kC18l$NM-8z!?L58z$r%H%0%k$9$k!#(B + * * (wnn-server-word-info dic-no entry) * dic-no: INTEGER * entry: INTEGER * RETURNS: (yomi kanji comment hindo hinsi) * DESCRIPTION: - * $B<-=q$+$i%(%s15(B $BSe(Bp $B1995jHV9f$G<($5$l$kC18l$N>pJs$rF@$k!(B# + * $B<-=q$+$i%(%s%H%jHV9f$G<($5$l$kC18l$N>pJs$rF@$k!#(B * * (wnn-server-word-hindo-set dic-no entry hindo) * dic-no: INTEGER @@ -202,7 +202,7 @@ * hindo: INTEGER * RETURNS: BOOLEAN * DESCRIPTION: - * $B<-=q$+$i%(%s15(B $BSe(Bp $B1995jHV9f$G<($5$l$kC18l$NIQEY$r@_Dj$9$k!(B# + * $B<-=q$+$i%(%s%H%jHV9f$G<($5$l$kC18l$NIQEY$r@_Dj$9$k!#(B * * (wnn-server-word-search yomi) * yomi: STRING @@ -213,30 +213,30 @@ * (wnn-server-dict-save) * RETURNS: BOOLEAN * DESCRIPTION: - * $BA4$F$N<-=q$HIQEY09:37:18!%$%k$r%;!<%V$9$k!(B# + * $BA4$F$N<-=q$HIQEY%U%!%$%k$r%;!<%V$9$k!#(B * * (wnn-server-get-param) * RETURNS: (n nsho p1 p2 p3 ... p15) - * DESCRIPTION: $BJQ49i%a!<%?$rF@$k!(B# + * DESCRIPTION: $BJQ49%Q%i%a!<%?$rF@$k!#(B * * (wnn-server-set-param n sho p1 ... p15) * RETURNS: $B%(%i!<$N;~(B nil - * DESCRIPTION: $BJQ49i%a!<%?$r@_Dj$9$k!(B# + * DESCRIPTION: $BJQ49%Q%i%a!<%?$r@_Dj$9$k!#(B * * (wnn-server-get-msg error-no) * RETURNS: $B%(%i!<%a225;!<%8(B - * DESCRIPTION: $B%(%i!<HV9f$+$i%a226;!<%8$rF@$k!#(B + * DESCRIPTION: $B%(%i!<HV9f$+$i%a%C%;!<%8$rF@$k!#(B * * (wnn-server-fuzokugo-set fname) * RETURNS: $B%(%i!<$N;~(B nil - * DESCRIPTION: $B/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!$KImB08l09:37:18!%$%k$rFI$_9~$`!(B# + * DESCRIPTION: $B%P%C%U%!$KImB08l%U%!%$%k$rFI$_9~$`!#(B * * (wnn-server-fuzokugo-get) - * RETURNS: $B09:37:18!%$%kL(B> - * DESCRIPTION: $B/export/willow0/xemacs-20.0-release/editor/src/mule/SCCS/s.mule-wnnfns.cC09:37:18!$NImB08l09:37:18!%$%kL>$rF@$k!(B# + * RETURNS: $B%U%!%$%kL>(B + * DESCRIPTION: $B%P%C%U%!$NImB08l%U%!%$%kL>$rF@$k!#(B * * (wnn-server-isconnect) - * RETURNS: $B%3mule-wnnfns.c/%H$7$F$l$P(B t, $B$7$F$J$1$l$P(B nil + * RETURNS: $B%3%M%/%H$7$F$l$P(B t, $B$7$F$J$1$l$P(B nil * DESCRIPTION: $B%5!<%P$H7Q$C$F$$$k$+D4$Y$k!#(B * * (wnn-server-hinsi-dicts hinsi-no) @@ -270,6 +270,7 @@ #include "window.h" #include "commonhd.h" +#include "mule-charset.h" #include "jllib.h" #include "cplib.h" @@ -283,12 +284,19 @@ #define WNNSERVER_T 2 #define WNNSERVER_K 3 +void w2m (w_char *wp, unsigned char *mp, unsigned char lb); +void m2w (unsigned char *mp, w_char *wp); +void w2y (w_char *w); +void c2m (unsigned char *cp, unsigned char *mp, unsigned char lb); +static void puts2 (char *s); +static int yes_or_no (unsigned char *s); + static struct wnn_buf *wnnfns_buf[NSERVER]; static struct wnn_env *wnnfns_env_norm[NSERVER]; static struct wnn_env *wnnfns_env_rev[NSERVER]; static int wnnfns_norm; static unsigned char lb_wnn_server_type[NSERVER] = -{LEADING_BYTE_JP, LEADING_BYTE_CN, LEADING_BYTE_INV, LEADING_BYTE_KR}; +{LEADING_BYTE_JAPANESE_JISX0208, LEADING_BYTE_CHINESE_GB2312, LEADING_BYTE_THAI_TIS620, LEADING_BYTE_KOREAN_KSC5601}; /* Lisp Variables and Constants Definition */ Lisp_Object Qjserver; @@ -298,6 +306,9 @@ Lisp_Object Qwnn_no_uniq; Lisp_Object Qwnn_uniq; Lisp_Object Qwnn_uniq_kanji; +Lisp_Object Qwnn_n, Qwnn_nsho, Qwnn_hindo, Qwnn_len, Qwnn_jiri, Qwnn_flag; +Lisp_Object Qwnn_jisho, Qwnn_sbn, Qwnn_dbn_len, Qwnn_sbn_cnt, Qwnn_suuji; +Lisp_Object Qwnn_kana, Qwnn_eisuu, Qwnn_kigou, Qwnn_toji_kakko, Qwnn_fuzokogo, Qwnn_kaikakko; Lisp_Object Vwnn_server_type; Lisp_Object Vcwnn_zhuyin; Lisp_Object Vwnnenv_sticky; @@ -313,7 +324,7 @@ login name LNAME in the server. Return nil if error occurs */ - (hname, lname)) + (hname, lname)) { char envname[32]; char langname[32]; @@ -339,12 +350,12 @@ strcpy (langname, "ko_KR"); break; } - strncpy (envname, XSTRING (lname)->data, 32); - if (NILP(hname)) strcpy (hostname, ""); + strncpy (envname, XSTRING (lname)->_data, 32); + if (EQ(hname, Qnil)) strcpy (hostname, ""); else { CHECK_STRING (hname); - strncpy (hostname, XSTRING (hname)->data, 32); + strncpy (hostname, XSTRING (hname)->_data, 32); } CHECK_STRING (lname); if (!(wnnfns_buf[snum] = jl_open_lang (envname, hostname, langname, @@ -372,20 +383,20 @@ Close the connection to jserver, Dictionary and friquency files are not saved. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; if (wnnfns_env_norm[snum]) { - if (NILP(Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); + if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); else jl_env_sticky_e (wnnfns_env_norm[snum]); jl_disconnect (wnnfns_env_norm[snum]); } if (wnnfns_env_rev[snum]) { - if (NILP(Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); + if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); else jl_env_sticky_e (wnnfns_env_rev[snum]); jl_disconnect (wnnfns_env_rev[snum]); } @@ -401,30 +412,28 @@ PRIORITY, DICT-FILE-MODE, FREQ-FILE-MODE. Specify password files of dictionary and frequency, PW1 and PW2, if needed. */ - (int nargs, Lisp_Object *args)) + (int nargs, Lisp_Object *args)) { - static int yes_or_no (); - static void puts2 (); struct gcpro gcpro1; int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); CHECK_INT (args[2]); - if (! NILP(args[5])) CHECK_STRING (args[5]); - if (! NILP(args[6])) CHECK_STRING (args[6]); + if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]); + if (!EQ(args[6], Qnil)) CHECK_STRING (args[6]); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if (jl_dic_add (wnnfns_buf[snum], - XSTRING (args[0])->data, - XSTRING (args[1])->data, + XSTRING (args[0])->_data, + XSTRING (args[1])->_data, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT (args[2]), - (NILP(args[3])) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (NILP(args[4])) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (NILP(args[5])) ? 0 : XSTRING (args[5])->data, - (NILP(args[6])) ? 0 : XSTRING (args[6])->data, + (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, + (EQ(args[4], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, + (EQ(args[5], Qnil)) ? 0 : XSTRING (args[5])->_data, + (EQ(args[6], Qnil)) ? 0 : XSTRING (args[6])->_data, yes_or_no, puts2 ) < 0) { @@ -438,7 +447,7 @@ DEFUN ("wnn-server-dict-delete", Fwnn_dict_delete, 1, 1, 0, /* Remove dictionary specified by DIC-NUMBER from buffer. */ - (dicno)) + (dicno)) { int no; int snum; @@ -453,7 +462,7 @@ DEFUN ("wnn-server-dict-list", Fwnn_dict_list, 0, 0, 0, /* Return information of dictionaries. */ - ()) + ()) { WNN_DIC_INFO *dicinfo; int cnt, i; @@ -489,8 +498,8 @@ DEFUN ("wnn-server-dict-comment", Fwnn_dict_comment, 2, 2, 0, /* Set comment to dictionary specified by DIC-NUMBER. Comment string COMMENT -*/ - (dicno, comment)) +*/ + (dicno, comment)) { w_char wbuf[512]; int snum; @@ -498,7 +507,7 @@ CHECK_STRING (comment); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (comment)->data, wbuf); + m2w (XSTRING (comment)->_data, wbuf); if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0) return Qnil; return Qt; @@ -508,11 +517,11 @@ DEFUN ("wnn-server-set-rev", Fwnn_set_rev, 1, 1, 0, /* Switch the translation mode to normal if T, or reverse if NIL. */ - (rev)) + (rev)) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (NILP(rev)) + if (EQ(rev, Qnil)) { if ((!wnnfns_buf[snum]) || (!wnnfns_env_norm[snum])) return; jl_env_set (wnnfns_buf[snum], wnnfns_env_norm[snum]); @@ -529,7 +538,7 @@ DEFUN ("wnn-server-henkan-begin", Fwnn_begin_henkan, 1, 1, 0, /* Translate YOMI string to kanji. Retuen the number of bunsetsu. */ - (hstring)) + (hstring)) { int cnt; w_char wbuf[5000]; @@ -537,7 +546,7 @@ CHECK_STRING (hstring); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (hstring)->data, wbuf); + m2w (XSTRING (hstring)->_data, wbuf); if (snum == WNNSERVER_C) w2y (wbuf); @@ -547,6 +556,7 @@ #else if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) return Qnil; +#endif return make_int (cnt); } @@ -554,7 +564,7 @@ Get zenkouho at BUNSETSU-NUMBER. Second argument DAI is T if dai-bunsetsu, NIL if sho-bunsetsu. Return the current offset of zenkouho. */ - (bunNo, dai)) + (bunNo, dai)) { int no, offset; int snum; @@ -563,10 +573,10 @@ if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; no = XINT (bunNo); - if (Vwnn_uniq_level == Qwnn_no_uniq) uniq_level = WNN_NO_UNIQ; - else if (Vwnn_uniq_level == Qwnn_uniq) uniq_level = WNN_UNIQ; + if (EQ(Vwnn_uniq_level, Qwnn_no_uniq)) uniq_level = WNN_NO_UNIQ; + else if (EQ(Vwnn_uniq_level, Qwnn_uniq)) uniq_level = WNN_UNIQ; else uniq_level = WNN_UNIQ_KNJ; - if (NILP(dai)) + if (EQ(dai, Qnil)) { if (offset = jl_zenkouho (wnnfns_buf[snum],no,WNN_USE_MAE, uniq_level) < 0) return Qnil; @@ -584,7 +594,7 @@ DEFUN ("wnn-server-get-zenkouho", Fwnn_get_zenkouho, 1, 1, 0, /* Get kanji string of KOUHO-NUMBER */ - (kouhoNo)) + (kouhoNo)) { unsigned char kanji_buf[256]; w_char wbuf[256]; @@ -602,7 +612,7 @@ DEFUN ("wnn-server-zenkouho-bun", Fwnn_zenkouho_bun, 0, 0, 0, /* For Wnn. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -612,7 +622,7 @@ DEFUN ("wnn-server-zenkouho-suu", Fwnn_zenkouho_suu, 0, 0, 0, /* Return the number of zen kouho */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -622,7 +632,7 @@ DEFUN ("wnn-server-dai-top", Fwnn_dai_top, 1, 1, 0, /* Return T if bunsetsu BUN-NUMBER is dai-bunsetsu. */ - (bunNo)) + (bunNo)) { int snum; CHECK_INT (bunNo); @@ -635,7 +645,7 @@ DEFUN ("wnn-server-dai-end", Fwnn_dai_end, 1, 1, 0, /* Return the bunsetu number of the next dai-bunsetsu after BUN-NUMBER. */ - (bunNo)) + (bunNo)) { int snum; CHECK_INT (bunNo); @@ -647,13 +657,13 @@ DEFUN ("wnn-server-henkan-kakutei", Fwnn_kakutei, 2, 2, 0, /* Set candidate with OFFSET, DAI. DAI is T if dai-bunsetsu. */ - (offset, dai)) + (offset, dai)) { int snum; CHECK_INT (offset); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (NILP(dai)) + if (EQ(dai, Qnil)) { if (jl_set_jikouho (wnnfns_buf[snum], XINT (offset)) < 0) return Qnil; } @@ -668,7 +678,7 @@ DEFUN ("wnn-server-bunsetu-henkou", Fwnn_bunsetu_henkou, 3, 3, 0, /* Change length of BUN-NUMBER bunsetu to LEN. DAI is T if dai-bunsetsu. */ - (bunNo, len, dai)) + (bunNo, len, dai)) { Lisp_Object val; int cnt, no; @@ -680,11 +690,11 @@ no = XINT (bunNo); #ifdef WNN6 if ((cnt = jl_fi_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (NILP(dai)) ? WNN_SHO : WNN_DAI)) < 0) + (dai == Qnil) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #else if ((cnt = jl_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (NILP(dai)) ? WNN_SHO : WNN_DAI)) < 0) + (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #endif return make_int (cnt); @@ -693,7 +703,7 @@ DEFUN ("wnn-server-inspect", Fwnn_inspect, 1, 1, 0, /* Get bunsetsu information specified by BUN-NUMBER. */ - (bunNo)) + (bunNo)) { Lisp_Object val; struct wnn_jdata *info_buf; @@ -732,7 +742,7 @@ DEFUN ("wnn-server-henkan-quit", Fwnn_quit_henkan, 0, 0, 0, /* do nothing */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -743,7 +753,7 @@ DEFUN ("wnn-server-bunsetu-kanji", Fwnn_bunsetu_kanji, 1, 1, 0, /* Get the pair of kanji and length of bunsetsu specified by BUN-NUMBER. */ - (bunNo)) + (bunNo)) { int no; unsigned char kanji_buf[256]; @@ -765,7 +775,7 @@ DEFUN ("wnn-server-bunsetu-yomi", Fwnn_bunsetu_yomi, 1, 1, 0, /* Get the pair of yomi and length of bunsetsu specified by BUN-NUMBER. */ - (bunNo)) + (bunNo)) { int no; unsigned char yomi_buf[256]; @@ -787,7 +797,7 @@ DEFUN ("wnn-server-bunsetu-suu", Fwnn_bunsetu_suu, 0, 0, 0, /* Get the number of bunsetsu. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -798,13 +808,13 @@ DEFUN ("wnn-server-hindo-update", Fwnn_hindo_update, 0, 1, 0, /* Update frequency of bunsetsu specified by NUM-NUMBER. */ - (bunNo)) + (bunNo)) { int no; Lisp_Object val; int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (NILP(bunNo)) no = -1; + if (EQ(bunNo, Qnil)) no = -1; else { CHECK_INT (bunNo); @@ -824,7 +834,7 @@ Add a word to dictionary. Arguments are DIC-NUMBER, KANJI, YOMI, COMMENT, HINSI-NUMBER */ - (dicno, kanji, yomi, comment, hinsi)) + (dicno, kanji, yomi, comment, hinsi)) { w_char yomi_buf[256], kanji_buf[256], comment_buf[256]; int snum; @@ -835,11 +845,11 @@ CHECK_INT (hinsi); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->data, yomi_buf); + m2w (XSTRING (yomi)->_data, yomi_buf); if (snum == WNNSERVER_C) w2y (yomi_buf); - m2w (XSTRING (kanji)->data, kanji_buf); - m2w (XSTRING (comment)->data, comment_buf); + m2w (XSTRING (kanji)->_data, kanji_buf); + m2w (XSTRING (comment)->_data, comment_buf); if (jl_word_add (wnnfns_buf[snum], XINT (dicno), yomi_buf, kanji_buf, comment_buf, XINT (hinsi), 0) < 0) return Qnil; @@ -850,7 +860,7 @@ DEFUN ("wnn-server-word-delete", Fwnn_word_sakujo, 2, 2, 0, /* Delete a word from dictionary, specified by DIC-NUMBER, SERIAL-NUMBER */ - (no, serial)) + (no, serial)) { int snum; CHECK_INT (no); @@ -866,7 +876,7 @@ DEFUN ("wnn-server-word-use", Fwnn_word_use, 2, 2, 0, /* Toggle on/off word, specified by DIC-NUMBER and SERIAL-NUMBER */ - (no, serial)) + (no, serial)) { int snum; CHECK_INT (no); @@ -881,7 +891,7 @@ DEFUN ("wnn-server-word-info", Fwnn_word_info, 2, 2, 0, /* Return list of yomi, kanji, comment, hindo, hinshi. */ - (no, serial)) + (no, serial)) { Lisp_Object val; struct wnn_jdata *info_buf; @@ -917,7 +927,7 @@ Set frequency to arbitrary value. Specified by DIC-NUMBER, SERIAL-NUMBER, FREQUENCY */ - (no, serial, hindo)) + (no, serial, hindo)) { int snum; CHECK_INT (no); @@ -939,7 +949,7 @@ Search a word YOMI from buffer. Return list of (kanji hinshi freq dic_no serial). */ - (yomi)) + (yomi)) { Lisp_Object val; struct wnn_jdata *wordinfo; @@ -953,7 +963,7 @@ if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->data, wbuf); + m2w (XSTRING (yomi)->_data, wbuf); if (snum == WNNSERVER_C) w2y (wbuf); if ((count = jl_word_search_by_env (wnnfns_buf[snum], @@ -977,7 +987,7 @@ DEFUN ("wnn-server-dict-save", Fwnn_dict_save, 0, 0, 0, /* Save all dictionaries and frequency files. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -990,7 +1000,7 @@ Returns (n nsho hindo len jiri flag jisho sbn dbn_len sbn_cnt suuji kana eisuu kigou toji_kakko fuzokogo kaikakko) */ - ()) + ()) { struct wnn_param param; int snum; @@ -1016,36 +1026,74 @@ Fcons (make_int (param.p15),Qnil))))))))))))))))); } -DEFUN ("wnn-server-set-param", Fwnn_set_param, 17, MANY, 0, /* -Set parameters, n nsho hindo len jiri flag jisho sbn dbn_len sbn_cnt -suuji kana eisuu kigou toji_kakko fuzokogo kaikakko +DEFUN ("wnn-server-set-param", Fwnn_set_param, 1, 1, 0, /* +Set parameters using an alist, where the CAR contains one of +wnn_n, wnn_nsho, wnn_hindo, wnn_len, wnn_jiri, wnn_flag, +wnn_jisho, wnn_sbn, wnn_dbn_len, wnn_sbn_cnt, wnn_suuji, +wnn_kana, wnn_eisuu, wnn_kigou, wnn_toji_kakko, wnn_fuzokogo, +or wnn_kaikakko and the CDR contains the value. */ - (int nargs, Lisp_Object *args)) + (Vsetvalues_alist)) { int rc; struct wnn_param param; + Lisp_Object tail, key, val; int snum; - for (rc = 0; rc < 17; rc++) CHECK_INT (args[rc]); + if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - param.n = XINT (args[0]); - param.nsho = XINT (args[1]); - param.p1 = XINT (args[2]); - param.p2 = XINT (args[3]); - param.p3 = XINT (args[4]); - param.p4 = XINT (args[5]); - param.p5 = XINT (args[6]); - param.p6 = XINT (args[7]); - param.p7 = XINT (args[8]); - param.p8 = XINT (args[9]); - param.p9 = XINT (args[10]); - param.p10 = XINT (args[11]); - param.p11 = XINT (args[12]); - param.p12 = XINT (args[13]); - param.p13 = XINT (args[14]); - param.p14 = XINT (args[15]); - param.p15 = XINT (args[16]); - + rc = jl_param_get (wnnfns_buf[snum], ¶m); + if (rc < 0) return Qnil; + + EXTERNAL_PROPERTY_LIST_LOOP (tail, key, val, Vsetvalues_alist) + { + int setval; + CHECK_INT (val); + setval = XINT (val); + if (EQ (key, Qwnn_n)) param.n = setval; + else if (EQ (key, Qwnn_nsho)) param.nsho = setval; + else if (EQ (key, Qwnn_hindo)) param.p1 = setval; + else if (EQ (key, Qwnn_len)) param.p2 = setval; + else if (EQ (key, Qwnn_jiri)) param.p3 = setval; + else if (EQ (key, Qwnn_flag)) param.p4 = setval; + else if (EQ (key, Qwnn_jisho)) param.p5 = setval; + else if (EQ (key, Qwnn_sbn)) param.p6 = setval; + else if (EQ (key, Qwnn_dbn_len)) param.p7 = setval; + else if (EQ (key, Qwnn_sbn_cnt)) param.p8 = setval; + else if (EQ (key, Qwnn_suuji)) param.p9 = setval; + else if (EQ (key, Qwnn_kana)) param.p10 = setval; + else if (EQ (key, Qwnn_eisuu)) param.p11 = setval; + else if (EQ (key, Qwnn_kigou)) param.p12 = setval; + else if (EQ (key, Qwnn_toji_kakko)) param.p13 = setval; + else if (EQ (key, Qwnn_fuzokogo)) param.p14 = setval; + else if (EQ (key, Qwnn_kaikakko)) param.p15 = setval; + else + { + signal_simple_error ("Invalid wnn keyword", key); + return Qnil; + } + } + +#if 0 + printf("wnn_n = %d\n",param.n); + printf("wnn_nsho = %d\n",param.nsho); + printf("wnn_hindo = %d\n",param.p1); + printf("wnn_len = %d\n",param.p2); + printf("wnn_jiri = %d\n",param.p3); + printf("wnn_flag = %d\n",param.p4); + printf("wnn_jisho = %d\n",param.p5); + printf("wnn_sbn = %d\n",param.p6); + printf("wnn_dbn_len = %d\n",param.p7); + printf("wnn_sbn_cnt = %d\n",param.p8); + printf("wnn_suuji = %d\n",param.p9); + printf("wnn_kana = %d\n",param.p10); + printf("wnn_eisuu = %d\n",param.p11); + printf("wnn_kigou = %d\n",param.p12); + printf("wnn_toji_kakko = %d\n",param.p13); + printf("wnn_fuzokogo = %d\n",param.p14); + printf("wnn_kaikakko = %d\n",param.p15); +#endif + rc = jl_param_set (wnnfns_buf[snum], ¶m); if (rc < 0) return Qnil; return Qt; @@ -1054,7 +1102,7 @@ DEFUN ("wnn-server-get-msg", Fwnn_get_msg, 0, 0, 0, /* Get message string from wnn_perror. */ - ()) + ()) { char mbuf[256]; char *msgp; @@ -1092,13 +1140,13 @@ DEFUN ("wnn-server-fuzokugo-set", Fwnn_fuzokugo_set, 1, 1, 0, /* For Wnn. */ - (file)) + (file)) { int snum; CHECK_STRING (file); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING (file)->data) < 0) + if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING (file)->_data) < 0) return Qnil; return Qt; } @@ -1106,7 +1154,7 @@ DEFUN ("wnn-server-fuzokugo-get", Fwnn_fuzokugo_get, 0, 0, 0, /* For Wnn. */ - ()) + ()) { char fname[256]; int snum; @@ -1120,7 +1168,7 @@ DEFUN ("wnn-server-isconnect", Fwnn_isconnect, 0, 0, 0, /* For Wnn. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -1132,7 +1180,7 @@ DEFUN ("wnn-server-hinsi-dicts", Fwnn_hinsi_dicts, 1, 1, 0, /* For Wnn. */ - (hinsi)) + (hinsi)) { int *area; int cnt; @@ -1155,7 +1203,7 @@ DEFUN ("wnn-server-hinsi-list", Fwnn_hinsi_list, 2, 2, 0, /* For Wnn. */ - (dicno, name)) + (dicno, name)) { int cnt; Lisp_Object val; @@ -1169,7 +1217,7 @@ if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->data, wbuf); + m2w (XSTRING (name)->_data, wbuf); if ((cnt = jl_hinsi_list (wnnfns_buf[snum], XINT (dicno), wbuf, &area)) < 0) return Qnil; if (cnt == 0) return make_int (0); @@ -1186,7 +1234,7 @@ DEFUN ("wnn-server-hinsi-name", Fwnn_hinsi_name, 1, 1, 0, /* For Wnn. */ - (no)) + (no)) { unsigned char name[256]; w_char *wname; @@ -1206,27 +1254,25 @@ FISYS-FREQ-FILE-MODE. Specify password files of dictionary and frequency, PW1 and PW2, if needed. */ - (int nargs, Lisp_Object *args)) + (int nargs, Lisp_Object *args)) { - static int yes_or_no(); - static void puts2(); struct gcpro gcpro1; int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (! NILP(args[3])) CHECK_STRING (args[3]); + if (args[3] != Qnil) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->data, - XSTRING(args[1])->data, + XSTRING(args[0])->_data, + XSTRING(args[1])->_data, WNN_FI_SYSTEM_DICT, WNN_DIC_RDONLY, - (NILP(args[2])) ? WNN_DIC_RDONLY : WNN_DIC_RW, + (args[2] == Qnil) ? WNN_DIC_RDONLY : WNN_DIC_RW, 0, - (NILP(args[3])) ? 0 : XSTRING(args[3])->data, + (args[3] == Qnil) ? 0 : XSTRING(args[3])->_data, yes_or_no, puts2 ) < 0) { UNGCPRO; @@ -1241,28 +1287,26 @@ FIUSR-DICT-FILE-MODE, FIUSR-FREQ-FILE-MODE. Specify password files of dictionary and frequency, PW1 and PW2, if needed. */ - (int nargs, Lisp_Object *args)) + (int nargs, Lisp_Object *args)) { - static int yes_or_no(); - static void puts2(); struct gcpro gcpro1; int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (! NILP(args[4])) CHECK_STRING (args[4]); - if (! NILP(args[5])) CHECK_STRING (args[5]); + if (args[4] != Qnil) CHECK_STRING (args[4]); + if (args[5] != Qnil) CHECK_STRING (args[5]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->data, - XSTRING(args[1])->data, + XSTRING(args[0])->_data, + XSTRING(args[1])->_data, WNN_FI_USER_DICT, - (NILP(args[2])) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (NILP(args[3])) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (NILP(args[4])) ? 0 : XSTRING(args[4])->data, - (NILP(args[5])) ? 0 : XSTRING(args[5])->data, + (args[2] == Qnil) ? WNN_DIC_RDONLY : WNN_DIC_RW, + (args[3] == Qnil) ? WNN_DIC_RDONLY : WNN_DIC_RW, + (args[4] == Qnil) ? 0 : XSTRING(args[4])->_data, + (args[5] == Qnil) ? 0 : XSTRING(args[5])->_data, yes_or_no, puts2 ) < 0) { UNGCPRO; @@ -1276,10 +1320,8 @@ Add dictionary specified by NOTRANS-DICT-FILE-NAME, PRIORITY, DICT-FILE-MODE. Specify password files of dictionary and frequency PW1 if needed. */ - (int nargs, Lisp_Object *args)) + (int nargs, Lisp_Object *args)) { - static int yes_or_no(); - static void puts2(); struct gcpro gcpro1; int snum; int dic_no; @@ -1288,7 +1330,7 @@ struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (! NILP(args[3])) CHECK_STRING (args[3]); + if (args[3] != Qnil) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1300,12 +1342,12 @@ dic_no = js_get_autolearning_dic(cur_env, WNN_MUHENKAN_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->data, + XSTRING(args[0])->_data, 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (NILP(args[3])) ? 0 : XSTRING(args[3])->data, + (args[3] == Qnil) ? 0 : XSTRING(args[3])->_data, 0, yes_or_no, puts2)) < 0) { @@ -1322,7 +1364,7 @@ } } vmask |= WNN_ENV_MUHENKAN_LEARN_MASK; - henv.muhenkan_flag = (NILP(args[2])) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.muhenkan_flag = (args[2] == Qnil) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1337,10 +1379,8 @@ Add dictionary specified by BMODIFY-DICT-FILE-NAME, PRIORITY, DICT-FILE-MODE. Specify password files of dictionary and frequency PW1 if needed. */ - (int nargs, Lisp_Object *args)) + (int nargs, Lisp_Object *args)) { - static int yes_or_no(); - static void puts2(); struct gcpro gcpro1; int snum; int dic_no; @@ -1349,7 +1389,7 @@ struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (! NILP(args[3])) CHECK_STRING (args[3]); + if (args[3] != Qnil) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1361,12 +1401,12 @@ dic_no = js_get_autolearning_dic(cur_env, WNN_BUNSETSUGIRI_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->data, + XSTRING(args[0])->_data, 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (NILP(args[3])) ? 0 : XSTRING(args[3])->data, + (args[3] == Qnil) ? 0 : XSTRING(args[3])->_data, 0, yes_or_no, puts2)) < 0) { @@ -1383,7 +1423,7 @@ } } vmask |= WNN_ENV_BUNSETSUGIRI_LEARN_MASK; - henv.bunsetsugiri_flag = (NILP(args[2])) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.bunsetsugiri_flag = (args[2] == Qnil) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1397,7 +1437,7 @@ DEFUN ("wnn-server-set-last-is-first", Fwnn_last_is_first, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1405,7 +1445,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_LAST_IS_FIRST_MASK; - henv.last_is_first_flag = (NILP(mode)) ? False : True; + henv.last_is_first_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1415,7 +1455,7 @@ DEFUN ("wnn-server-set-complex-conv-mode", Fwnn_complex_conv, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1423,7 +1463,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMPLEX_CONV_MASK; - henv.complex_flag = (NILP(mode)) ? False : True; + henv.complex_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1433,7 +1473,7 @@ DEFUN ("wnn-server-set-okuri-learn-mode", Fwnn_okuri_learn, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1441,7 +1481,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_OKURI_LEARN_MASK; - henv.okuri_learn_flag = (NILP(mode)) ? False : True; + henv.okuri_learn_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1451,7 +1491,7 @@ DEFUN ("wnn-server-set-okuri-flag", Fwnn_okuri_flag, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1475,7 +1515,7 @@ DEFUN ("wnn-server-set-prefix-learn-mode", Fwnn_prefix_learn, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1483,7 +1523,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_PREFIX_LEARN_MASK; - henv.prefix_learn_flag = (NILP(mode)) ? False : True; + henv.prefix_learn_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1493,7 +1533,7 @@ DEFUN ("wnn-server-set-prefix-flag", Fwnn_prefix_flag, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1515,7 +1555,7 @@ DEFUN ("wnn-server-set-suffix-learn-mode", Fwnn_suffix_learn, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1523,7 +1563,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_SUFFIX_LEARN_MASK; - henv.suffix_learn_flag = (NILP(mode)) ? False : True; + henv.suffix_learn_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1533,7 +1573,7 @@ DEFUN ("wnn-server-set-common-learn-mode", Fwnn_common_learn, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1541,7 +1581,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMMON_LAERN_MASK; - henv.common_learn_flag = (NILP(mode)) ? False : True; + henv.common_learn_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1551,7 +1591,7 @@ DEFUN ("wnn-server-set-freq-func-mode", Fwnn_freq_func, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1573,7 +1613,7 @@ DEFUN ("wnn-server-set-numeric-mode", Fwnn_numeric, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1601,7 +1641,7 @@ DEFUN ("wnn-server-set-alphabet-mode", Fwnn_alphabet, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1623,7 +1663,7 @@ DEFUN ("wnn-server-set-symbol-mode", Fwnn_symbol, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1645,7 +1685,7 @@ DEFUN ("wnn-server-set-yuragi-mode", Fwnn_yuragi, 1, 1, 0, /* For FI-Wnn. */ - (mode)) + (mode)) { int snum; unsigned long vmask = 0; @@ -1653,7 +1693,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_YURAGI_MASK; - henv.yuragi_flag = (NILP(mode)) ? False : True; + henv.yuragi_flag = (mode == Qnil) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1663,7 +1703,7 @@ DEFUN ("wnn-reset-previous-info", Fwnn_reset_prev, 0, 0, 0, /* For FI-Wnn. */ - ()) + ()) { int snum; if ((snum = check_wnn_server_type()) == -1) return Qnil; @@ -1676,7 +1716,7 @@ DEFUN ("wnn-server-version", Fwnn_version, 0, 0, 0, /* Returns Wnn server version ID. */ - ()) + ()) { int snum; int serv; @@ -1695,7 +1735,7 @@ DEFUN ("wnn-server-hinsi-number", Fwnn_hinsi_number, 1, 1, 0, /* For Wnn. */ - (name)) + (name)) { w_char w_buf[256]; int no; @@ -1703,7 +1743,7 @@ CHECK_STRING (name); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->data, w_buf); + m2w (XSTRING (name)->_data, w_buf); if ((no = jl_hinsi_number (wnnfns_buf[snum], w_buf)) < 0) return Qnil; return make_int (no); } @@ -1780,6 +1820,23 @@ defsymbol (&Qwnn_no_uniq, "wnn-no-uniq"); defsymbol (&Qwnn_uniq, "wnn-uniq"); defsymbol (&Qwnn_uniq_kanji, "wnn-uniq-kanji"); + defsymbol (&Qwnn_n, "wnn_n"); + defsymbol (&Qwnn_nsho, "wnn_nsho"); + defsymbol (&Qwnn_hindo, "wnn_hindo"); + defsymbol (&Qwnn_len, "wnn_len"); + defsymbol (&Qwnn_jiri, "wnn_jiri"); + defsymbol (&Qwnn_flag, "wnn_flag"); + defsymbol (&Qwnn_jisho, "wnn_jisho"); + defsymbol (&Qwnn_sbn, "wnn_sbn"); + defsymbol (&Qwnn_dbn_len, "wnn_dbn_len"); + defsymbol (&Qwnn_sbn_cnt, "wnn_sbn_cnt"); + defsymbol (&Qwnn_suuji, "wnn_suuji"); + defsymbol (&Qwnn_kana, "wnn_kana"); + defsymbol (&Qwnn_eisuu, "wnn_eisuu"); + defsymbol (&Qwnn_kigou, "wnn_kigou"); + defsymbol (&Qwnn_toji_kakko, "wnn_toji_kakko"); + defsymbol (&Qwnn_fuzokogo, "wnn_fuzokogo"); + defsymbol (&Qwnn_kaikakko, "wnn_kaikakko"); } void @@ -1829,17 +1886,17 @@ switch (wc & 0x8080) { case 0x80: - if (Vwnn_server_type == Qcserver) + if (EQ(Vwnn_server_type, Qcserver)) { len = cwnn_yincod_pzy (pzy, wc, - (NILP(Vcwnn_zhuyin)) + (EQ(Vcwnn_zhuyin, Qnil)) ? CWNN_PINYIN : CWNN_ZHUYIN); for (i = 0; i < len; i++) { if (pzy[i] & 0x80) { - *mp++ = LEADING_BYTE_PRV11; + *mp++ = PRE_LEADING_BYTE_PRIVATE_1; /* #### Not sure about this one... */ *mp++ = lb_sisheng; } *mp++ = pzy[i]; @@ -1847,7 +1904,7 @@ } else { - *mp++ = LEADING_BYTE_KANA; + *mp++ = LEADING_BYTE_KATAKANA_JISX0201; *mp++ = (wc & 0xff); } break; @@ -1857,10 +1914,10 @@ *mp++ = wc & 0x00ff; break; case 0x8000: - if (lb == LEADING_BYTE_JP) - *mp++ = LEADING_BYTE_JP2; - else if (lb == LEADING_BYTE_BIG5_1) - *mp++ = LEADING_BYTE_BIG5_2; + if (lb == LEADING_BYTE_JAPANESE_JISX0208) + *mp++ = LEADING_BYTE_JAPANESE_JISX0212; + else if (lb == LEADING_BYTE_CHINESE_BIG5_1) + *mp++ = LEADING_BYTE_CHINESE_BIG5_2; else *mp++ = lb; *mp++ = (wc & 0xff00) >> 8; @@ -1881,31 +1938,27 @@ while (ch = *mp++) { - if (BUFBYTE_ASCII_P (ch)) - { - *wp++ = ch; - } - else if (BUFBYTE_LEADING_BYTE_P (ch)) + if (BUFBYTE_LEADING_BYTE_P (ch)) { switch (ch) { - case LEADING_BYTE_KANA: + case LEADING_BYTE_KATAKANA_JISX0201: *wp++ = *mp++; break; - case LEADING_BYTE_ROMAN: + case LEADING_BYTE_LATIN_JISX0201: *wp++ = *mp++ & 0x7F; break; - case LEADING_BYTE_JPOLD: - case LEADING_BYTE_CN: - case LEADING_BYTE_JP: - case LEADING_BYTE_KR: + case LEADING_BYTE_JAPANESE_JISX0208_1978: + case LEADING_BYTE_CHINESE_GB2312: + case LEADING_BYTE_JAPANESE_JISX0208: + case LEADING_BYTE_KOREAN_KSC5601: /* case LEADING_BYTE_TW: */ ch = *mp++; *wp++ = (ch << 8) | *mp++; break; - case LEADING_BYTE_JP2: + case LEADING_BYTE_JAPANESE_JISX0212: ch = *mp++; *wp++ = (ch << 8) | (*mp++ & 0x7f); break; - case LEADING_BYTE_PRV11: + case PRE_LEADING_BYTE_PRIVATE_1: /* #### Not sure about this one... */ ch = *mp++; if (ch == lb_sisheng) *wp++ = 0x8e80 | *mp++; @@ -1913,9 +1966,13 @@ mp++; break; default: /* ignore this character */ - mp += mule_charset_bytes[ch] - 1; + mp += REP_BYTES_BY_FIRST_BYTE(ch) - 1; } } + else + { + *wp++ = ch; + } } *wp = 0; } @@ -1944,7 +2001,7 @@ w++; pin++; } len = cwnn_pzy_yincod (ybuf, pbuf, - (NILP(Vcwnn_zhuyin)) ? CWNN_PINYIN : CWNN_ZHUYIN); + (EQ(Vcwnn_zhuyin, Qnil)) ? CWNN_PINYIN : CWNN_ZHUYIN); if (len <= 0) return; @@ -1985,7 +2042,7 @@ static int yes_or_no (unsigned char *s) { - extern Lisp_Object Fy_or_n_p (); + extern Lisp_Object Fy_or_n_p(); unsigned char mbuf[512]; unsigned char lb; int len; @@ -1993,19 +2050,31 @@ if ((snum = check_wnn_server_type ()) == -1) return 0; lb = lb_wnn_server_type[snum]; /* if no message found, create file without query */ -/* if (wnn_msg_cat->msg_bd == 0) return 1;*/ + /* if (wnn_msg_cat->msg_bd == 0) return 1;*/ if (*s == 0) return 1; c2m (s, mbuf, lb); /* truncate "(Y/N)" */ for (len = 0; (mbuf[len]) && (len < 512); len++); for (; (mbuf[len] != '(') && (len > 0); len--); - if (NILP(Fy_or_n_p (make_string (mbuf, len)))) return 0; +#if 0 + if (Fy_or_n_p (make_string (mbuf, len)) == Qnil) return 0; else return (1); +#else + { + Lisp_Object yes, str; + + str = make_string (mbuf, len); + yes = call1(Qyes_or_no_p, EQ(str, Qnil)); + if (NILP (yes)) return 0; + else return (1); + } +#endif } static void puts2 (char *s) { +#if 0 Lisp_Object args[1]; char mbuf[512]; unsigned char lb; @@ -2016,16 +2085,19 @@ c2m (s, mbuf, lb); args[0] = make_string (mbuf, strlen (mbuf)); Fmessage (1, args); +#else + message("%s",s); +#endif } int check_wnn_server_type (void) { - if (Vwnn_server_type == Qjserver) + if (EQ(Vwnn_server_type, Qjserver)) { return WNNSERVER_J; } - else if (Vwnn_server_type == Qcserver) + else if (EQ(Vwnn_server_type, Qcserver)) { return WNNSERVER_C; } @@ -2033,7 +2105,7 @@ { return WNNSERVER_T; } */ - else if (Vwnn_server_type == Qkserver) + else if (EQ(Vwnn_server_type, Qkserver)) { return WNNSERVER_K; } diff -r 498bf5da1c90 -r 0d2f883870bc src/puresize.h --- a/src/puresize.h Mon Aug 13 09:12:43 2007 +0200 +++ b/src/puresize.h Mon Aug 13 09:13:56 2007 +0200 @@ -34,7 +34,7 @@ #if (LONGBITS == 64) # define BASE_PURESIZE 893000 #else -# define BASE_PURESIZE 518000 +# define BASE_PURESIZE 563000 #endif /* If any particular systems need to change the base puresize, they @@ -83,10 +83,15 @@ #else # define MULE_PURESIZE_CANNA 0 #endif +#ifdef HAVE_WNN +# define MULE_PURESIZE_WNN 5000 +#else +# define MULE_PURESIZE_WNN 0 +#endif # if (LONGBITS == 64) -# define MULE_PURESIZE_EXTRA 99000+MULE_PURESIZE_CANNA +# define MULE_PURESIZE_EXTRA 99000+MULE_PURESIZE_CANNA+MULE_PURESIZE_WNN # else -# define MULE_PURESIZE_EXTRA 78000+MULE_PURESIZE_CANNA +# define MULE_PURESIZE_EXTRA 78000+MULE_PURESIZE_CANNA+MULE_PURESIZE_WNN # endif #else # define MULE_PURESIZE_EXTRA 0 @@ -115,11 +120,7 @@ /* Extra amount of purespace needed for Sunpro builds. */ #ifdef SUNPRO -#ifdef MULE /* ~50k extra for tm */ -# define SUNPRO_PURESIZE_EXTRA 135000 -#else #define SUNPRO_PURESIZE_EXTRA 85000 -#endif #else # define SUNPRO_PURESIZE_EXTRA 0 #endif diff -r 498bf5da1c90 -r 0d2f883870bc src/s/freebsd.h --- a/src/s/freebsd.h Mon Aug 13 09:12:43 2007 +0200 +++ b/src/s/freebsd.h Mon Aug 13 09:13:56 2007 +0200 @@ -33,7 +33,15 @@ #define PENDING_OUTPUT_COUNT(FILE) ((FILE)->_p - (FILE)->_bf._base) #define LIBS_DEBUG +/* FreeBSD 2.2 or later */ +#ifndef __FreeBSD_version +#include <osreldate.h> +#endif +#if __FreeBSD_version >= 199701 +#define LIBS_SYSTEM -lutil -lxpg4 +#else #define LIBS_SYSTEM -lutil +#endif /* XEmacs change: */ #ifdef HAVE_NCURSES #define LIBS_TERMCAP -lncurses -ltermcap diff -r 498bf5da1c90 -r 0d2f883870bc src/s/sol2.h --- a/src/s/sol2.h Mon Aug 13 09:12:43 2007 +0200 +++ b/src/s/sol2.h Mon Aug 13 09:13:56 2007 +0200 @@ -41,7 +41,7 @@ /* The standard Solaris library nsl has this function in it which is supposed to only be in the BSD compat stuff. Yuck. Of course, there isn't a prototype for it other than in /usr/ucbinclude. */ -int gethostname (char *, int); +int gethostname (char *, size_t); /* Get non-ANSI functions from ANSI header files in cc -Xc mode. Sun has promised to fix setjmp.h */ diff -r 498bf5da1c90 -r 0d2f883870bc src/window.c --- a/src/window.c Mon Aug 13 09:12:43 2007 +0200 +++ b/src/window.c Mon Aug 13 09:13:56 2007 +0200 @@ -4041,15 +4041,23 @@ } +extern int signal_error_on_buffer_boundary; + DEFUN ("scroll-up", Fscroll_up, 0, 1, "_P", /* Scroll text of current window upward ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll downward. When calling from a program, supply a number as argument or nil. + +If `signal-error-on-buffer-boundary' is nil, the usual error and +loss of zmacs region is suppressed when moving past end of buffer. */ (n)) { - window_scroll (Fselected_window (Qnil), n, 1, ERROR_ME); + Error_behavior errb = + signal_error_on_buffer_boundary ? ERROR_ME : ERROR_ME_NOT; + + window_scroll (Fselected_window (Qnil), n, 1, errb); return Qnil; } @@ -4058,10 +4066,16 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll upward. When calling from a program, supply a number as argument or nil. + +If `signal-error-on-buffer-boundary' is nil, the usual error and +loss of zmacs region is suppressed when moving past end of buffer. */ (n)) { - window_scroll (Fselected_window (Qnil), n, -1, ERROR_ME); + Error_behavior errb = + signal_error_on_buffer_boundary ? ERROR_ME : ERROR_ME_NOT; + + window_scroll (Fselected_window (Qnil), n, -1, errb); return Qnil; }