Mercurial > emacs
changeset 111571:91de9477a77a
merge trunk
| author | Kenichi Handa <handa@m17n.org> |
|---|---|
| date | Wed, 22 Sep 2010 15:46:51 +0900 |
| parents | ffe2002d45c4 (current diff) 6afc6a92ca9b (diff) |
| children | b3f9490f0b7f |
| files | README.imagemagick etc/emacs.bash etc/emacs.csh etc/ms-kermit lisp/net/tramp-fish.el lisp/nxml/TODO |
| diffstat | 238 files changed, 15541 insertions(+), 14369 deletions(-) [+] |
line wrap: on
line diff
--- a/.bzrignore Wed Sep 08 12:55:57 2010 +0900 +++ b/.bzrignore Wed Sep 22 15:46:51 2010 +0900 @@ -56,6 +56,7 @@ lisp/cus-load.el lisp/eshell/esh-groups.el lisp/finder-inf.el +lisp/gnus/_dir-locals.el nextstep/Emacs.app nt/config.log src/_dbxinit @@ -72,3 +73,4 @@ src/stamp-oldxmenu src/temacs test/indent/*.new ++*
--- a/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,25 @@ +2010-09-20 Dan Nicolaescu <dann@ics.uci.edu> + + * configure.in (LINKER): Rename to LD_FIRSTFLAG, do not include $(CC). + +2010-09-18 Eli Zaretskii <eliz@gnu.org> + + * config.bat: Detect that libxml2 is installed and if so, build + with it. + +2010-09-13 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * configure.in (HAVE_LIBXML2): Check that the libxml2 we found can + be used. This fixes a conf problem on Mac OS X. + +2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * configure.in: Check for libxml2. + +2010-09-09 Glenn Morris <rgm@gnu.org> + + * make-dist: No more TODO files under lisp/. + 2010-09-04 Eli Zaretskii <eliz@gnu.org> * config.bat: Produce lisp/gnus/_dir-locals.el from
--- a/README.imagemagick Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,151 +0,0 @@ -* README for the ImageMagick Emacs branch - -This is the imagemagick branch of Emacs. Imagemagick can now be used -to load many new image formats, and also do useful transforms like -scaling and rotation. - -This file will attempt to contain draft NEWS, Changelog and manual -entries for the new functionality. - -You might need to regenerate the configure scripts: -aclocal -automake -autoheader -autoconf -./configure --with-imagemagick - - -* TODO image-type-header-regexps priorities the jpeg loader over the -imagemagick one. This is not wrong, but how should a user go about -prefering the imagemagick loader? The user might like zooming etc in -jpegs. - -try (setq image-type-header-regexps nil) for a quick hack to prefer -imagemagick over the jpg loader. - -* TODO For some reason its unbearably slow to look at a page in a large - image bundle using the :index feature. The imagemagick "display" - command is also a bit slow, but nowhere near as slow as the emacs - code. It seems imagemagick tries to unpack every page when loading - the bundle. This feature is not the primary usecase for the - imagemagick patch though. - - ImageMagick 6.6.2-9 introduced a bugfix for single page djvu load. - It is now way faster to use the :index feature, but its still not - very fast. - -** DONE optimize number of pages calculation for bundles as suggested by - imagemagick forum: "set the density to something low like 2 and use - MagickPingImage()" - -** TODO try to cache the num pages calculation. it can take a while to - calculate the number of pages, and if you need to do it for each - page view, page-flipping becomes uselessly slow. - -* TODO integrate with image-dired - -* TODO integrate with docview. - -* TODO integrate with image-mode -Some work has been done, M-x image-transform-fit-to-height will fit -the image to the height of the Emacs window for instance. - -* TODO look for optimizations for handling images with low depth -Currently the code seems to default to 24 bit RGB which is costly for -images with lower bit depth. - -* TODO complete documentation drafts below - -* DONE fix inconsistencys with spelling of imagemagick in the src -* DONE report number of images in image bundle types somehow -Works like for "gif" support. Thanks to Juri Linkov. -* DONE probably add pdf to inhibited types -* DONE inhibit types is defconst should probably be defcustom -* TODO decide what to do with some uncommitted imagemagick support - functions for image size etc. -* TODO Test with more systems -Tested on Fedora 12, Fedora 14 so far, and the libmagick that ships with it. -Ubuntu 8.04 was also tested, but it seems it ships a broken -ImageMagick. - -I also tried using an imagemagick compiled from their SVN, in -parallell with the one packaged by Fedora, it worked well. - -* DONE Also need some way to handle render methods that only work on newer ImageMagicks -Is handled by configure now - -* Some nits from Stefan Monnier -I just took a quick look at the code and I see the following nits to fix: - -** DONE obviously a merge will have to come with a good ChangeLog. -** DONE also the merge will need to come with documentation. Maybe not in the - Texinfo form yet, but at least in the etc/NEWS with enough info that - describes the `scale' and other such arguments that someone can start - using them. -** DONE the README talks about naming inconsistencies, I think these should be - fixed before a first commit (should be straightforward). - -** DONE the "let" in image.el should not be followed by a line break and the while - should be replaced by a dolist. - -** DONE the prototype of imagemagick_load_image has some odd indentation in ([[2010.06.14]]) - its args, not sure what happened. -** DONE a few lines in the C code break the 80columns limit. -** DONE please use ANSI style function declarations rather than K&R for new code. ([[2010.06.14]]) -** DONE you can get rid of the prototypes by reordering the code. ([[2010.06.14]]) -** DONE the docstrings in DEFUN should not be indented (they'll display ([[2010.06.14]]) - weirdly otherwise in C-h f). -** DONE Some "{" are at the end of a for/if rather than on their own line. ([[2010.06.14]]) -** DONE why use "*( imtypes + i)" rather than "imtypes[i]"? ([[2010.06.14]]) -** DONE some "," lack a space after them. ([[2010.06.14]]) -** DONE several "=" and "==" lack spaces around them. ([[2010.06.14]]) - - -* NEWS entry -** ImageMagick support -It is now possible to use the Imagemagick library to load many new -image formats in Emacs. - -To enable, use the following configure option: ---with-imagemagick - -The new function (imagemagick-types) returns a list of image file -extensions that your installation of imagemagick supports. - -The function (imagemagick-register-types) will enable the imagemagick -support for the extensions in imagemagick-types minus the types listed -in imagemagick-types-inhibit. - -imagemagick-types-inhibit has the value '(C HTML HTM TXT PDF) by default. -This means imagemagick will be used also to load jpeg files, if you -have both jpeg and imagemagick libraries linked. Add 'JPG to -imagemagick-types-inhibit if you do not want this. - -imagemagick-render-type is a new variable which can be set to choose -between screen render methods. - -- 0 is a conservative metod which works with older ImageMagick - versions. It is a bit slow, but robust. - -- 1 utilizes a newer ImageMagick method - - -Images loaded with imagemagick will support a couple of new display -specification behaviours: - -- if the :width and :height keywords are specified, these values are -used for scaling the image. If only one of :width or :height is -specified, the other one will be calculated so as to preserve the -aspect ratio.If both :width and :height are specified, aspect ratio -will not be preserved. - -- :rotation specifies a rotation angle in degrees. - -- :index specifies which image inside an image bundle file format, such -as TIFF or DJVM, to view. - -The image-metadata function can be used to retrieve the total number -of images in an image bundle. This is simmilar to how GIF files work. - -* Manual entry -nothing yet, but the NEWS entry could be adapted.
--- a/admin/unidata/unidata-gen.el Wed Sep 08 12:55:57 2010 +0900 +++ b/admin/unidata/unidata-gen.el Wed Sep 22 15:46:51 2010 +0900 @@ -95,7 +95,7 @@ (with-temp-buffer ;; Insert a file of this format: ;; (CHAR NAME CATEGORY ...) - ;; where CHAR is a charater code, the following elements are strings + ;; where CHAR is a character code, the following elements are strings ;; representing character properties. (insert-file-contents unidata-text-file) (goto-char (point-min))
--- a/config.bat Wed Sep 08 12:55:57 2010 +0900 +++ b/config.bat Wed Sep 22 15:46:51 2010 +0900 @@ -38,6 +38,7 @@ set nodebug= set djgpp_ver= set sys_malloc= +set libxml= if "%1" == "" goto usage rem ---------------------------------------------------------------------- rem See if their environment is large enough. We need 28 bytes. @@ -175,6 +176,24 @@ rem For details see lisp.h where it defines USE_LSB_TAG echo #define NO_DECL_ALIGN >>config.h2 :alignOk +Rem See if they have libxml2 later than v2.2.0 installed +Echo Checking whether libxml2 v2.2.1 or later is installed ... +rm -f junk.c junk.o junk junk.exe +rem Use djecho here because we need to quote brackets +djecho "#include <libxml/xmlversion.h>" >junk.c +djecho "int main()" >>junk.c +djecho "{return (LIBXML_VERSION > 20200 ? 0 : 1);}" >>junk.c +redir -o Nul -eo gcc -I/dev/env/DJDIR/include/libxml2 -o junk junk.c +if not exist junk Goto xmlDone +if not exist junk.exe coff2exe junk +junk +If ErrorLevel 1 Goto xmlDone +Echo Configuring with libxml2 ... +sed -e "/#undef HAVE_LIBXML2/s/^.*$/#define HAVE_LIBXML2 1/" <config.h2 >config.h3 +mv config.h3 config.h2 +set libxml=1 +:xmlDone +rm -f junk.c junk junk.exe Rem See if they requested a SYSTEM_MALLOC build if "%sys_malloc%" == "" Goto cfgDone rm -f config.tmp @@ -213,6 +232,12 @@ sed -e "/^LDFLAGS *=/s/=/=-s/" <makefile.tmp >Makefile rm -f makefile.tmp :src6 + +if "%libxml%" == "" goto src7 +sed -e "/^LIBXML2_LIBS *=/s/=/= -lxml2 -lz -liconv/" <Makefile >makefile.tmp +sed -e "/^LIBXML2_CFLAGS *=/s|=|= -I/dev/env/DJDIR/include/libxml2|" <makefile.tmp >Makefile +rm -f makefile.tmp +:src7 cd .. rem ---------------------------------------------------------------------- Echo Configuring the library source directory... @@ -289,6 +314,7 @@ set nodebug= set djgpp_ver= set sys_malloc= +set libxml= goto skipArchTag arch-tag: 2d2fed23-4dc6-4006-a2e4-49daf0031f33
--- a/configure Wed Sep 08 12:55:57 2010 +0900 +++ b/configure Wed Sep 22 15:46:51 2010 +0900 @@ -599,7 +599,7 @@ TOOLTIP_SUPPORT MOUSE_SUPPORT LIB_GCC -LINKER +LD_FIRSTFLAG LD_SWITCH_SYSTEM_TEMACS POST_ALLOC_OBJ PRE_ALLOC_OBJ @@ -660,6 +660,8 @@ LIBS_MAIL liblockfile ALLOCA +LIBXML2_LIBS +LIBXML2_CFLAGS LIBXSM LIBGPM LIBGIF @@ -807,6 +809,7 @@ with_gif with_png with_rsvg +with_xml2 with_imagemagick with_xft with_libotf @@ -1514,6 +1517,7 @@ --without-gif don't compile with GIF image support --without-png don't compile with PNG image support --without-rsvg don't compile with SVG image support + --without-xml2 don't compile with XML parsing support --with-imagemagick compile with ImageMagick image support --without-xft don't use XFT for anti aliased fonts --without-libotf don't use libotf for OpenType font support @@ -2732,6 +2736,14 @@ fi +# Check whether --with-xml2 was given. +if test "${with_xml2+set}" = set; then : + withval=$with_xml2; +else + with_xml2=yes +fi + + # Check whether --with-imagemagick was given. if test "${with_imagemagick+set}" = set; then : withval=$with_imagemagick; @@ -11070,6 +11082,160 @@ fi +### Use libxml (-lxml2) if available +if test "${with_xml2}" != "no"; then + ### I'm not sure what the version number should be, so I just guessed. + + succeeded=no + + # Extract the first word of "pkg-config", so it can be a program name with args. +set dummy pkg-config; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_path_PKG_CONFIG+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + case $PKG_CONFIG in + [\\/]* | ?:[\\/]*) + ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_path_PKG_CONFIG="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_path_PKG_CONFIG" && ac_cv_path_PKG_CONFIG="no" + ;; +esac +fi +PKG_CONFIG=$ac_cv_path_PKG_CONFIG +if test -n "$PKG_CONFIG"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $PKG_CONFIG" >&5 +$as_echo "$PKG_CONFIG" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + if test "$PKG_CONFIG" = "no" ; then + HAVE_LIBXML2=no + else + PKG_CONFIG_MIN_VERSION=0.9.0 + if $PKG_CONFIG --atleast-pkgconfig-version $PKG_CONFIG_MIN_VERSION; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for libxml-2.0 > 2.2.0" >&5 +$as_echo_n "checking for libxml-2.0 > 2.2.0... " >&6; } + + if $PKG_CONFIG --exists "libxml-2.0 > 2.2.0" 2>&5; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + succeeded=yes + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking LIBXML2_CFLAGS" >&5 +$as_echo_n "checking LIBXML2_CFLAGS... " >&6; } + LIBXML2_CFLAGS=`$PKG_CONFIG --cflags "libxml-2.0 > 2.2.0"|sed -e 's,///*,/,g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LIBXML2_CFLAGS" >&5 +$as_echo "$LIBXML2_CFLAGS" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking LIBXML2_LIBS" >&5 +$as_echo_n "checking LIBXML2_LIBS... " >&6; } + LIBXML2_LIBS=`$PKG_CONFIG --libs "libxml-2.0 > 2.2.0"|sed -e 's,///*,/,g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LIBXML2_LIBS" >&5 +$as_echo "$LIBXML2_LIBS" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + LIBXML2_CFLAGS="" + LIBXML2_LIBS="" + ## If we have a custom action on failure, don't print errors, but + ## do set a variable so people can do so. + LIBXML2_PKG_ERRORS=`$PKG_CONFIG --errors-to-stdout --print-errors "libxml-2.0 > 2.2.0"` + + fi + + + + else + echo "*** Your version of pkg-config is too old. You need version $PKG_CONFIG_MIN_VERSION or newer." + echo "*** See http://www.freedesktop.org/software/pkgconfig" + fi + fi + + if test $succeeded = yes; then + HAVE_LIBXML2=yes + else + HAVE_LIBXML2=no + fi + + if test "${HAVE_LIBXML2}" = "yes"; then + LIBS="$LIBXML2_LIBS $LIBS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for htmlReadMemory in -lxml2" >&5 +$as_echo_n "checking for htmlReadMemory in -lxml2... " >&6; } +if test "${ac_cv_lib_xml2_htmlReadMemory+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lxml2 $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char htmlReadMemory (); +int +main () +{ +return htmlReadMemory (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_xml2_htmlReadMemory=yes +else + ac_cv_lib_xml2_htmlReadMemory=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_xml2_htmlReadMemory" >&5 +$as_echo "$ac_cv_lib_xml2_htmlReadMemory" >&6; } +if test "x$ac_cv_lib_xml2_htmlReadMemory" = x""yes; then : + HAVE_LIBXML2=yes +else + HAVE_LIBXML2=no +fi + + if test "${HAVE_LIBXML2}" = "yes"; then + +$as_echo "#define HAVE_LIBXML2 1" >>confdefs.h + + else + LIBXML2_LIBS="" + LIBXML2_CFLAGS="" + fi + fi +fi + + + # If netdb.h doesn't declare h_errno, we must declare it by hand. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether netdb declares h_errno" >&5 $as_echo_n "checking whether netdb declares h_errno... " >&6; } @@ -14537,7 +14703,7 @@ -LINKER= +LD_FIRSTFLAG= ORDINARY_LINK= case "$opsys" in ## gnu: GNU needs its own crt0. @@ -14547,14 +14713,14 @@ ## library search parth, i.e. it won't search /usr/lib for libc and ## friends. Using -nostartfiles instead avoids this problem, and ## will also work on earlier NetBSD releases. - netbsd|openbsd) LINKER="\$(CC) -nostartfiles" ;; + netbsd|openbsd) LD_FIRSTFLAG="-nostartfiles" ;; ## macpcc: NAKAJI Hiroyuki <nakaji@tutrp.tut.ac.jp> says ## MkLinux/LinuxPPC needs this. ## ibms390x only supports opsys = gnu-linux so it can be added here. gnu-*) case "$machine" in - macppc|ibms390x) LINKER="\$(CC) -nostdlib" ;; + macppc|ibms390x) LD_FIRSTFLAG="-nostdlib" ;; esac ;; esac @@ -14562,14 +14728,14 @@ if test "x$ORDINARY_LINK" = "xyes"; then - LINKER="\$(CC)" + LD_FIRSTFLAG="" $as_echo "#define ORDINARY_LINK 1" >>confdefs.h -## The system files defining neither ORDINARY_LINK nor LINKER are: +## The system files defining neither ORDINARY_LINK nor LD_FIRSTFLAG are: ## freebsd, gnu-* not on macppc|ibms390x. -elif test "x$GCC" = "xyes" && test "x$LINKER" = "x"; then +elif test "x$GCC" = "xyes" && test "x$LD_FIRSTFLAG" = "x"; then ## Versions of GCC >= 2.0 put their library, libgcc.a, in obscure ## places that are difficult to figure out at make time. Fortunately, @@ -14579,18 +14745,17 @@ ## Well, it is not quite perfect. The "-nostdlib" keeps GCC from ## searching for libraries in its internal directories, so we have to ## ask GCC explicitly where to find libgcc.a (LIB_GCC below). - LINKER="\$(CC) -nostdlib" -fi - -test "x$LINKER" = "x" && LINKER=ld + LD_FIRSTFLAG="-nostdlib" +fi + ## FIXME? What setting of EDIT_LDFLAGS should this have? -test "$NS_IMPL_GNUSTEP" = "yes" && LINKER="\$(CC) -rdynamic" +test "$NS_IMPL_GNUSTEP" = "yes" && LD_FIRSTFLAG="-rdynamic" ## FIXME? The logic here is not precisely the same as that above. -## There is no check here for a pre-defined LINKER. +## There is no check here for a pre-defined LD_FIRSTFLAG. ## Should we only be setting LIB_GCC if LD ~ -nostdlib? LIB_GCC= if test "x$GCC" = "xyes" && test "x$ORDINARY_LINK" != "xyes"; then
--- a/configure.in Wed Sep 08 12:55:57 2010 +0900 +++ b/configure.in Wed Sep 22 15:46:51 2010 +0900 @@ -155,6 +155,7 @@ OPTION_DEFAULT_ON([gif],[don't compile with GIF image support]) OPTION_DEFAULT_ON([png],[don't compile with PNG image support]) OPTION_DEFAULT_ON([rsvg],[don't compile with SVG image support]) +OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_OFF([imagemagick],[compile with ImageMagick image support]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) @@ -2535,6 +2536,24 @@ fi AC_SUBST(LIBXSM) +### Use libxml (-lxml2) if available +if test "${with_xml2}" != "no"; then + ### I'm not sure what the version number should be, so I just guessed. + PKG_CHECK_MODULES(LIBXML2, libxml-2.0 > 2.2.0, HAVE_LIBXML2=yes, HAVE_LIBXML2=no) + if test "${HAVE_LIBXML2}" = "yes"; then + LIBS="$LIBXML2_LIBS $LIBS" + AC_CHECK_LIB(xml2, htmlReadMemory, HAVE_LIBXML2=yes, HAVE_LIBXML2=no) + if test "${HAVE_LIBXML2}" = "yes"; then + AC_DEFINE(HAVE_LIBXML2, 1, [Define to 1 if you have the libxml library (-lxml2).]) + else + LIBXML2_LIBS="" + LIBXML2_CFLAGS="" + fi + fi +fi +AC_SUBST(LIBXML2_LIBS) +AC_SUBST(LIBXML2_CFLAGS) + # If netdb.h doesn't declare h_errno, we must declare it by hand. AC_CACHE_CHECK(whether netdb declares h_errno, emacs_cv_netdb_declares_h_errno, @@ -3354,7 +3373,7 @@ AC_SUBST(LD_SWITCH_SYSTEM_TEMACS) -LINKER= +LD_FIRSTFLAG= ORDINARY_LINK= case "$opsys" in ## gnu: GNU needs its own crt0. @@ -3364,14 +3383,14 @@ ## library search parth, i.e. it won't search /usr/lib for libc and ## friends. Using -nostartfiles instead avoids this problem, and ## will also work on earlier NetBSD releases. - netbsd|openbsd) LINKER="\$(CC) -nostartfiles" ;; + netbsd|openbsd) LD_FIRSTFLAG="-nostartfiles" ;; ## macpcc: NAKAJI Hiroyuki <nakaji@tutrp.tut.ac.jp> says ## MkLinux/LinuxPPC needs this. ## ibms390x only supports opsys = gnu-linux so it can be added here. gnu-*) case "$machine" in - macppc|ibms390x) LINKER="\$(CC) -nostdlib" ;; + macppc|ibms390x) LD_FIRSTFLAG="-nostdlib" ;; esac ;; esac @@ -3379,12 +3398,12 @@ if test "x$ORDINARY_LINK" = "xyes"; then - LINKER="\$(CC)" + LD_FIRSTFLAG="" AC_DEFINE(ORDINARY_LINK, 1, [Define if the C compiler is the linker.]) -## The system files defining neither ORDINARY_LINK nor LINKER are: +## The system files defining neither ORDINARY_LINK nor LD_FIRSTFLAG are: ## freebsd, gnu-* not on macppc|ibms390x. -elif test "x$GCC" = "xyes" && test "x$LINKER" = "x"; then +elif test "x$GCC" = "xyes" && test "x$LD_FIRSTFLAG" = "x"; then ## Versions of GCC >= 2.0 put their library, libgcc.a, in obscure ## places that are difficult to figure out at make time. Fortunately, @@ -3394,18 +3413,17 @@ ## Well, it is not quite perfect. The "-nostdlib" keeps GCC from ## searching for libraries in its internal directories, so we have to ## ask GCC explicitly where to find libgcc.a (LIB_GCC below). - LINKER="\$(CC) -nostdlib" + LD_FIRSTFLAG="-nostdlib" fi -test "x$LINKER" = "x" && LINKER=ld ## FIXME? What setting of EDIT_LDFLAGS should this have? -test "$NS_IMPL_GNUSTEP" = "yes" && LINKER="\$(CC) -rdynamic" - -AC_SUBST(LINKER) +test "$NS_IMPL_GNUSTEP" = "yes" && LD_FIRSTFLAG="-rdynamic" + +AC_SUBST(LD_FIRSTFLAG) ## FIXME? The logic here is not precisely the same as that above. -## There is no check here for a pre-defined LINKER. +## There is no check here for a pre-defined LD_FIRSTFLAG. ## Should we only be setting LIB_GCC if LD ~ -nostdlib? LIB_GCC= if test "x$GCC" = "xyes" && test "x$ORDINARY_LINK" != "xyes"; then
--- a/doc/emacs/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,23 @@ +2010-09-14 Glenn Morris <rgm@gnu.org> + + * cal-xtra.texi (Fancy Diary Display): Emphasize that sort should be + the last hook item. + + * calendar.texi (Appointments): Also updated when a diary include file + is saved. + +2010-09-14 Glenn Morris <rgm@gnu.org> + + * trouble.texi (Bugs): Update the section intro. + (Known Problems): New section. + (Checklist): Misc updates. Prefer M-x report-emacs-bug. + (Sending Patches): Bug fixes are best as responses to existing bugs. + * emacs.texi (Known Problems): Add menu entry for new section. + +2010-09-09 Glenn Morris <rgm@gnu.org> + + * xresources.texi: Untabify. + 2010-09-06 Chong Yidong <cyd@stupidchicken.com> * dired.texi (Dired Enter): Minor doc fix (Bug#6982).
--- a/doc/emacs/cal-xtra.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/cal-xtra.texi Wed Sep 22 15:46:51 2010 +0900 @@ -613,7 +613,9 @@ @noindent For each day, this sorts diary entries that begin with a recognizable time of day according to their times. Diary entries without times come -first within each day. +first within each day. Note how the sort command is placed at the end +of the hook list, in case earlier members of the list change the order +of the diary entries, or add items. @vindex diary-include-string Your main diary file can include other files. This permits a group of
--- a/doc/emacs/calendar.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/calendar.texi Wed Sep 22 15:46:51 2010 +0900 @@ -1508,7 +1508,14 @@ time by re-enabling appointment notification. Both these actions also display the day's diary buffer, unless you set @code{appt-display-diary} to @code{nil}. The appointments list is -also updated whenever the diary file is saved. +also updated whenever the diary file (or a file it includes; see +@iftex +@inforef{Fancy Diary Display,, emacs-xtra}) +@end iftex +@ifnottex +@ref{Fancy Diary Display}) +@end ifnottex +is saved. @findex appt-add @findex appt-delete
--- a/doc/emacs/emacs.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/emacs.texi Wed Sep 22 15:46:51 2010 +0900 @@ -1137,6 +1137,7 @@ Reporting Bugs +* Known Problems:: How to read about known problems and bugs. * Bug Criteria:: Have you really found a bug? * Understanding Bug Reporting:: How to report a bug effectively. * Checklist:: Steps to follow for a good bug report.
--- a/doc/emacs/trouble.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/trouble.texi Wed Sep 22 15:46:51 2010 +0900 @@ -409,29 +409,76 @@ @section Reporting Bugs @cindex bugs - Sometimes you will encounter a bug in Emacs. Although we cannot -promise we can or will fix the bug, and we might not even agree that it -is a bug, we want to hear about problems you encounter. Often we agree -they are bugs and want to fix them. - - To make it possible for us to fix a bug, you must report it. In order -to do so effectively, you must know when and how to do it. - - Before reporting a bug, it is a good idea to see if it is already -known. You can find the list of known problems in the file -@file{etc/PROBLEMS} in the Emacs distribution; type @kbd{C-h C-p} to read -it. Some additional user-level problems can be found in @ref{Bugs and -problems, , Bugs and problems, efaq, GNU Emacs FAQ}. Looking up your -problem in these two documents might provide you with a solution or a -work-around, or give you additional information about related issues. + If you think you have found a bug in Emacs, please report it. We +cannot promise to fix it, or always to agree that it is a bug, but we +certainly want to hear about it. The same applies for new features +you would like to see added. The following sections will help you to +construct an effective bug report. @menu +* Known Problems:: How to read about known problems and bugs. * Criteria: Bug Criteria. Have you really found a bug? * Understanding Bug Reporting:: How to report a bug effectively. * Checklist:: Steps to follow for a good bug report. * Sending Patches:: How to send a patch for GNU Emacs. @end menu +@node Known Problems +@subsection Reading Existing Bug Reports and Known Problems + + Before reporting a bug, if at all possible please check to see if it +is already known about. Indeed, it may already have been fixed in a +later release of Emacs, or in the development version. Here is a list +of the main places you can read about known issues: + +@itemize +@item +The @file{etc/PROBLEMS} file in the Emacs distribution; type @kbd{C-h +C-p} to read it. This file contains a list of particularly well-known +issues that have been encountered in compiling, installing and running +Emacs. Often, there are suggestions for workarounds and solutions. + +@item +Some additional user-level problems can be found in @ref{Bugs and +problems, , Bugs and problems, efaq, GNU Emacs FAQ}. + +@item +The @samp{bug-gnu-emacs} mailing list (also available as the newsgroup +@samp{gnu.emacs.bug}). This is where you will find most Emacs bug +reports. You can read the list archives at +@url{http://lists.gnu.org/mailman/listinfo/bug-gnu-emacs}. If you +like, you can also subscribe to the list. Be aware that the sole +purpose of this list is to provide the Emacs maintainers with +information about bugs and feature requests. Reports may contain +fairly large amounts of data; spectators should not complain about +this. + +@item +The bug tracker at @url{http://debbugs.gnu.org}. From early 2008, +reports from the @samp{bug-gnu-emacs} list have been sent here. The +tracker contains the same information as the mailing list, just in a +different format. You may prefer to browse and read reports using the +tracker. + +@item +The @samp{emacs-pretest-bug} mailing list. This list is no longer +used, and is mainly of historical interest. At one time, it was used +for bug reports in development (i.e., not yet released) versions of +Emacs. You can read the archives for 2003 to mid 2007 at +@url{http://lists.gnu.org/archive/html/emacs-pretest-bug/}. From +late 2007 to mid 2008, the address was an alias for the +@samp{emacs-devel} mailing list. From mid 2008 onwards, it has been +an alias for @samp{bug-gnu-emacs}. + +@item +The @samp{emacs-devel} mailing list. Sometimes people report bugs to +this mailing list. This is not the main purpose of the list, however, +and it is much better to send bug reports to the bug list. You should +not feel obliged to read this list before reporting a bug. + +@end itemize + + @node Bug Criteria @subsection When Is There a Bug @@ -540,56 +587,81 @@ @subsection Checklist for Bug Reports @cindex reporting bugs - The best way to send a bug report is to mail it electronically to the -Emacs maintainers at @email{bug-gnu-emacs@@gnu.org}. (If you want to -suggest a change as an improvement, use the same address.) + + Before reporting a bug, first try to see if the problem has already +been reported (@pxref{Known Problems}). - If you'd like to read the bug reports, you can find them on the -newsgroup @samp{gnu.emacs.bug}; keep in mind, however, that as a -spectator you should not criticize anything about what you see there. -The purpose of bug reports is to give information to the Emacs -maintainers. Spectators are welcome only as long as they do not -interfere with this. In particular, some bug reports contain fairly -large amounts of data; spectators should not complain about this. - - Please do not post bug reports using netnews; mail is more reliable -than netnews about reporting your correct address, which we may need -in order to ask you for more information. If your data is more than -500,000 bytes, please don't include it directly in the bug report; -instead, offer to send it on request, or make it available by ftp and -say where. +If you are able to, try the latest release of Emacs to see if the +problem has already been fixed. Even better is to try the latest +development version. We recognize that this is not easy for some +people, so do not feel that you absolutely must do this before making +a report. @findex report-emacs-bug - A convenient way to send a bug report for Emacs is to use the command -@kbd{M-x report-emacs-bug}. This sets up a mail buffer (@pxref{Sending -Mail}) and automatically inserts @emph{some} of the essential -information. However, it cannot supply all the necessary information; -you should still read and follow the guidelines below, so you can enter -the other crucial information by hand before you send the message. + The best way to write a bug report for Emacs is to use the command +@kbd{M-x report-emacs-bug}. This sets up a mail buffer +(@pxref{Sending Mail}) and automatically inserts @emph{some} of the +essential information. However, it cannot supply all the necessary +information; you should still read and follow the guidelines below, so +you can enter the other crucial information by hand before you send +the message. You may feel that some of the information inserted by +@kbd{M-x report-emacs-bug} is not relevant, but unless you are +absolutely sure it is best to leave it, so that the developers can +decide for themselves. + +When you have finished writing your report, type @kbd{C-c C-c} and it +will be sent to the Emacs maintainers at @email{bug-gnu-emacs@@gnu.org}. +(If you want to suggest an improvement or new feature, use the same +address.) If you cannot send mail from inside Emacs, you can copy the +text of your report to your normal mail client and send it to that +address. Or you can simply send an email to that address describing +the problem. + +Your report will be sent to the @samp{bug-gnu-emacs} mailing list, and +stored in the tracker at @url{http://debbugs.gnu.org}. Please try to +include a valid reply email address, in case we need to ask you for +more information about your report. Submissions are moderated, so +there may be a delay before your report appears. + +You do not need to know how the @url{http://debbugs.gnu.org} bug +tracker works in order to report a bug, but if you want to, you can +read the tracker's online documentation to see the various features +you can use. + +All mail sent to the @samp{bug-gnu-emacs} mailing list is also +gatewayed to the @samp{bug.gnu.emacs} newsgroup. The reverse is also +true, but we ask you not to post bug reports via the newsgroup. It +can make it much harder to contact you if we need to ask for more +information, and it does not integrate well with the bug tracker. + +If your data is more than 500,000 bytes, please don't include it +directly in the bug report; instead, offer to send it on request, or +make it available by ftp and say where. To enable maintainers to investigate a bug, your report should include all these things: @itemize @bullet @item -The version number of Emacs. Without this, we won't know whether there -is any point in looking for the bug in the current version of GNU -Emacs. +The version number of Emacs. Without this, we won't know whether there is any +point in looking for the bug in the current version of GNU Emacs. -You can get the version number by typing @kbd{M-x emacs-version -@key{RET}}. If that command does not work, you probably have something -other than GNU Emacs, so you will have to report the bug somewhere -else. +@kbd{M-x report-emacs-bug} includes this information automatically, +but if you are not using that command for your report you can get the +version number by typing @kbd{M-x emacs-version @key{RET}}. If that +command does not work, you probably have something other than GNU +Emacs, so you will have to report the bug somewhere else. @item The type of machine you are using, and the operating system name and -version number. @kbd{M-x emacs-version @key{RET}} provides this -information too. Copy its output from the @samp{*Messages*} buffer, so -that you get it all and get it accurately. +version number (again, automatically included by @kbd{M-x +report-emacs-bug}). @kbd{M-x emacs-version @key{RET}} provides this +information too. Copy its output from the @samp{*Messages*} buffer, +so that you get it all and get it accurately. @item The operands given to the @code{configure} command when Emacs was -installed. +installed (automatically included by @kbd{M-x report-emacs-bug}). @item A complete list of any modifications you have made to the Emacs source. @@ -619,12 +691,15 @@ @item The precise commands we need to type to reproduce the bug. +If at all possible, give a full recipe for an Emacs started with the +@samp{-Q} option (@pxref{Initial Options}). This bypasses your +@file{.emacs} customizations. @findex open-dribble-file @cindex dribble file @cindex logging keystrokes -The easy way to record the input to Emacs precisely is to write a -dribble file. To start the file, execute the Lisp expression +One way to record the input to Emacs precisely is to write a dribble +file. To start the file, execute the Lisp expression @example (open-dribble-file "~/dribble") @@ -735,7 +810,7 @@ including your @file{.emacs} file, set any variables that may affect the functioning of Emacs. Also, see whether the problem happens in a freshly started Emacs without loading your @file{.emacs} file (start -Emacs with the @code{-q} switch to prevent loading the init file). If +Emacs with the @code{-Q} switch to prevent loading the init files). If the problem does @emph{not} occur then, you must report the precise contents of any programs that you must load into the Lisp world in order to cause the problem to occur. @@ -907,12 +982,10 @@ @itemize @bullet @item Send an explanation with your changes of what problem they fix or what -improvement they bring about. For a bug fix, just include a copy of the -bug report, and explain why the change fixes the bug. - -(Referring to a bug report is not as good as including it, because then -we will have to look it up, and we have probably already deleted it if -we've already fixed the bug.) +improvement they bring about. For a fix for an existing bug, it is +best to reply to the relevant discussion on the @samp{bug-gnu-emacs} +list, or item in the @url{http://debbugs.gnu.org} tracker. Explain +why your change fixes the bug. @item Always include a proper bug report for the problem you think you have
--- a/doc/emacs/xresources.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/emacs/xresources.texi Wed Sep 22 15:46:51 2010 +0900 @@ -480,7 +480,7 @@ For dialog boxes, use @samp{dialog*}: @example -Emacs.dialog*.faceName: Sans-12 +Emacs.dialog*.faceName: Sans-12 @end example @noindent
--- a/doc/lispref/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/lispref/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,15 @@ +2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * text.texi (Special Properties): Clarify when modification-hooks run. + +2010-09-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * syntax.texi (Syntax Flags): Document new `c' flag. + +2010-09-09 Glenn Morris <rgm@gnu.org> + + * display.texi (ImageMagick Images): General cleanup. + 2010-09-06 Alexander Klimov <alserkli@inbox.ru> (tiny change) * files.texi (Directory Names): Use \` rather than ^.
--- a/doc/lispref/display.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/lispref/display.texi Wed Sep 22 15:46:51 2010 +0900 @@ -4468,47 +4468,56 @@ @node ImageMagick Images @subsection ImageMagick Images -The Imagemagick library can be used to load many image formats in Emacs. - -The function (imagemagick-types) returns a list of image file -extensions that your installation of imagemagick supports. - -The function (imagemagick-register-types) will enable the imagemagick -support for the extensions in imagemagick-types minus the types listed -in imagemagick-types-inhibit. - -imagemagick-types-inhibit has the value '(C HTML HTM TXT PDF) by -default. There can be overlap between image loaders in your Emacs -installation. If you never want to use the ImageMagick loader to use -Jpeg files, for instance, add 'JPG to imagemagick-types-inhibit. Which -loader that will be used in practice depends on the priority of the -loaders. - -imagemagick-render-type is a new variable which can be set to choose -between screen render methods for the ImageMagick loader. - -- 0 is a conservative metod which works with older ImageMagick - versions. It is a bit slow, but robust. - -- 1 utilizes a newer ImageMagick method - - -Images loaded with imagemagick will support a couple of new display -specification behaviours: - -- if the :width and :height keywords are specified, these values are -used for scaling the image. If only one of :width or :height is -specified, the other one will be calculated so as to preserve the -aspect ratio.If both :width and :height are specified, aspect ratio -will not be preserved. - -- :rotation specifies a rotation angle in degrees. - -- :index specifies which image inside an image bundle file format, such -as TIFF or DJVM, to view. - -The image-metadata function can be used to retrieve the total number -of images in an image bundle. This is simmilar to how GIF files work. +@cindex ImageMagick images +@cindex images, support for more formats + + If you build Emacs with ImageMagick (@url{http://www.imagemagick.org}) +support, you can use the ImageMagick library to load many image formats. + +@findex imagemagick-types +The function @code{imagemagick-types} returns a list of image file +extensions that your installation of ImageMagick supports. To enable +support, you must call the function @code{imagemagick-register-types}. + +@vindex imagemagick-types-inhibit +The variable @code{imagemagick-types-inhibit} specifies a list of +image types that you do @emph{not} want ImageMagick to handle. There +may be overlap between image loaders in your Emacs installation, and +you may prefer to use a different one for a given image type (which +@c FIXME how is this priority determined? +loader will be used in practice depends on the priority of the loaders). +@c FIXME why are these uppercase when image-types is lower-case? +@c FIXME what are the possibe options? Are these actually file extensions? +For example, if you never want to use the ImageMagick loader to use +JPEG files, add @code{JPG} to this list. + +@vindex imagemagick-render-type +You can set the variable @code{imagemagick-render-type} to choose +between screen render methods for the ImageMagick loader. The options +are: @code{0}, a conservative method which works with older +@c FIXME details of this "newer method"? +@c Presumably it is faster but may be less "robust"? +ImageMagick versions (it is a bit slow, but robust); and @code{1}, +a newer ImageMagick method. + +Images loaded with ImageMagick support a few new display specifications: + +@table @code +@item :width, :height +The @code{:width} and @code{:height} keywords are used for scaling the +image. If only one of them is specified, the other one will be +calculated so as to preserve the aspect ratio. If both are specified, +aspect ratio may not be preserved. + +@item :rotation +Specifies a rotation angle in degrees. + +@item :index +Specifies which image to view inside an image bundle file format, such +as TIFF or DJVM. You can use the @code{image-metadata} function to +retrieve the total number of images in an image bundle (this is +similar to how GIF files work). +@end table @node Other Image Types
--- a/doc/lispref/syntax.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/lispref/syntax.texi Wed Sep 22 15:46:51 2010 +0900 @@ -292,19 +292,21 @@ @cindex syntax flags In addition to the classes, entries for characters in a syntax table -can specify flags. There are seven possible flags, represented by the -characters @samp{1}, @samp{2}, @samp{3}, @samp{4}, @samp{b}, @samp{n}, -and @samp{p}. +can specify flags. There are eight possible flags, represented by the +characters @samp{1}, @samp{2}, @samp{3}, @samp{4}, @samp{b}, @samp{c}, +@samp{n}, and @samp{p}. - All the flags except @samp{n} and @samp{p} are used to describe -multi-character comment delimiters. The digit flags indicate that a -character can @emph{also} be part of a comment sequence, in addition to -the syntactic properties associated with its character class. The flags -are independent of the class and each other for the sake of characters -such as @samp{*} in C mode, which is a punctuation character, @emph{and} -the second character of a start-of-comment sequence (@samp{/*}), -@emph{and} the first character of an end-of-comment sequence -(@samp{*/}). + All the flags except @samp{p} are used to describe comment +delimiters. The digit flags are used for comment delimiters made up +of 2 characters. They indicate that a character can @emph{also} be +part of a comment sequence, in addition to the syntactic properties +associated with its character class. The flags are independent of the +class and each other for the sake of characters such as @samp{*} in +C mode, which is a punctuation character, @emph{and} the second +character of a start-of-comment sequence (@samp{/*}), @emph{and} the +first character of an end-of-comment sequence (@samp{*/}). The flags +@samp{b}, @samp{c}, and @samp{n} are used to qualify the corresponding +comment delimiter. Here is a table of the possible flags for a character @var{c}, and what they mean: @@ -325,63 +327,62 @@ @samp{4} means @var{c} is the second character of such a sequence. @item -@c Emacs 19 feature @samp{b} means that @var{c} as a comment delimiter belongs to the -alternative ``b'' comment style. +alternative ``b'' comment style. For a two-character comment starter, +this flag is only significant on the second char, and for a 2-character +comment ender it is only significant on the first char. + +@item +@samp{c} means that @var{c} as a comment delimiter belongs to the +alternative ``c'' comment style. For a two-character comment +delimiter, @samp{c} on either character makes it of style ``c''. -Emacs supports two comment styles simultaneously in any one syntax -table. This is for the sake of C++. Each style of comment syntax has -its own comment-start sequence and its own comment-end sequence. Each -comment must stick to one style or the other; thus, if it starts with -the comment-start sequence of style ``b,'' it must also end with the -comment-end sequence of style ``b.'' +@item +@samp{n} on a comment delimiter character specifies +that this kind of comment can be nested. For a two-character +comment delimiter, @samp{n} on either character makes it +nestable. -The two comment-start sequences must begin with the same character; only -the second character may differ. Mark the second character of the -``b''-style comment-start sequence with the @samp{b} flag. +Emacs supports several comment styles simultaneously in any one syntax +table. A comment style is a set of flags @samp{b}, @samp{c}, and +@samp{n}, so there can be up to 8 different comment styles. +Each comment delimiter has a style and only matches comment delimiters +of the same style. Thus if a comment starts with the comment-start +sequence of style ``bn'', it will extend until the next matching +comment-end sequence of style ``bn''. -A comment-end sequence (one or two characters) applies to the ``b'' -style if its first character has the @samp{b} flag set; otherwise, it -applies to the ``a'' style. - -The appropriate comment syntax settings for C++ are as follows: +The appropriate comment syntax settings for C++ can be as follows: @table @asis @item @samp{/} -@samp{124b} +@samp{124} @item @samp{*} -@samp{23} +@samp{23b} @item newline -@samp{>b} +@samp{>} @end table This defines four comment-delimiting sequences: @table @asis @item @samp{/*} -This is a comment-start sequence for ``a'' style because the -second character, @samp{*}, does not have the @samp{b} flag. +This is a comment-start sequence for ``b'' style because the +second character, @samp{*}, has the @samp{b} flag. @item @samp{//} -This is a comment-start sequence for ``b'' style because the second -character, @samp{/}, does have the @samp{b} flag. +This is a comment-start sequence for ``a'' style because the second +character, @samp{/}, does not have the @samp{b} flag. @item @samp{*/} -This is a comment-end sequence for ``a'' style because the first -character, @samp{*}, does not have the @samp{b} flag. +This is a comment-end sequence for ``b'' style because the first +character, @samp{*}, does have the @samp{b} flag. @item newline -This is a comment-end sequence for ``b'' style, because the newline -character has the @samp{b} flag. +This is a comment-end sequence for ``a'' style, because the newline +character does not have the @samp{b} flag. @end table @item -@samp{n} on a comment delimiter character specifies -that this kind of comment can be nested. For a two-character -comment delimiter, @samp{n} on either character makes it -nestable. - -@item @c Emacs 19 feature @samp{p} identifies an additional ``prefix character'' for Lisp syntax. These characters are treated as whitespace when they appear between
--- a/doc/lispref/text.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/lispref/text.texi Wed Sep 22 15:46:51 2010 +0900 @@ -59,6 +59,7 @@ position stored in a register. * Base 64:: Conversion to or from base 64 encoding. * MD5 Checksum:: Compute the MD5 "message digest"/"checksum". +* Parsing HTML:: Parsing HTML and XML. * Atomic Changes:: Installing several buffer changes "atomically". * Change Hooks:: Supplying functions to be run when text is changed. @end menu @@ -3229,12 +3230,16 @@ @cindex hooks for changing a character @kindex modification-hooks @r{(text property)} If a character has the property @code{modification-hooks}, then its -value should be a list of functions; modifying that character calls all -of those functions. Each function receives two arguments: the beginning -and end of the part of the buffer being modified. Note that if a -particular modification hook function appears on several characters -being modified by a single primitive, you can't predict how many times -the function will be called. +value should be a list of functions; modifying that character calls +all of those functions before the actual modification. Each function +receives two arguments: the beginning and end of the part of the +buffer being modified. Note that if a particular modification hook +function appears on several characters being modified by a single +primitive, you can't predict how many times the function will +be called. +Furthermore, insertion will not modify any existing character, so this +hook will only be run when removing some characters, replacing them +with others, or changing their text-properties. If these functions modify the buffer, they should bind @code{inhibit-modification-hooks} to @code{t} around doing so, to @@ -4106,6 +4111,49 @@ coding instead. @end defun +@node Parsing HTML +@section Parsing HTML +@cindex parsing html +@cindex parsing xml + +Emacs provides an interface to the @code{libxml2} library via two +functions: @code{html-parse-buffer} and @code{xml-parse-buffer}. The +HTML function will parse ``real world'' HTML and try to return a +sensible parse tree, while the XML function is somewhat stricter about +syntax. + +They both take a two optional parameter. The first is a buffer, and +the second is a base URL to be used to expand relative URLs in the +document, if any. + +Here's an example demonstrating the structure of the parsed data you +get out. Given this HTML document: + +@example +<html><hEad></head><body width=101><div class=thing>Foo<div>Yes +@end example + +You get this parse tree: + +@example +(html + (head) + (body + (:width . "101") + (div + (:class . "thing") + (text . "Foo") + (div + (text . "Yes\n"))))) +@end example + +It's a simple tree structure, where the @code{car} for each node is +the name of the node, and the @code{cdr} is the value, or the list of +values. + +Attributes are coded the same way as child nodes, but with @samp{:} as +the first character. + @node Atomic Changes @section Atomic Change Groups @cindex atomic changes
--- a/doc/misc/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,29 @@ +2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (Expunging mailboxes): Update name of the expunging + command. + +2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * emacs-mime.texi (rfc2047): Update description for + rfc2047-encode-parameter. + +2010-09-13 Michael Albinus <michael.albinus@gmx.de> + + * tramp.texi (Inline methods): Remove "ssh1_old", "ssh2_old" and + "fish" methods. + (External methods): Remove "scp1_old" and "scp2_old" methods. + +2010-09-09 Michael Albinus <michael.albinus@gmx.de> + + * tramp.texi: Remove Japanese manual. Fix typo. + + * trampver.texi: Update release number. Remove japanesemanual. + +2010-09-09 Glenn Morris <rgm@gnu.org> + + * org.texi: Restore clobbered changes (copyright years, untabify). + 2010-09-04 Julien Danjou <julien@danjou.info> (tiny change) * gnus.texi (Adaptive Scoring): Fix typo.
--- a/doc/misc/emacs-mime.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/emacs-mime.texi Wed Sep 22 15:46:51 2010 +0900 @@ -1469,21 +1469,9 @@ @item rfc2047-encode-parameter @findex rfc2047-encode-parameter -Encode a parameter in the RFC2047-like style. This is a replacement for -the @code{rfc2231-encode-string} function. @xref{rfc2231}. - -When attaching files as @acronym{MIME} parts, we should use the RFC2231 -encoding to specify the file names containing non-@acronym{ASCII} -characters. However, many mail softwares don't support it in practice -and recipients won't be able to extract files with correct names. -Instead, the RFC2047-like encoding is acceptable generally. This -function provides the very RFC2047-like encoding, resigning to such a -regrettable trend. To use it, put the following line in your -@file{~/.gnus.el} file: - -@lisp -(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) -@end lisp +Encode a parameter in the RFC2047-like style. This is a substitution +for the @code{rfc2231-encode-string} function, that is the standard but +many mailers don't support it. @xref{rfc2231}. @end table
--- a/doc/misc/gnus-news.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/gnus-news.texi Wed Sep 22 15:46:51 2010 +0900 @@ -18,6 +18,17 @@ @itemize @bullet +@item Supported Emacs versions +The following Emacs versions are supported by No Gnus: +@itemize @bullet + +@item Emacs 22 and up +@item XEmacs 21.4 +@item XEmacs 21.5 +@item SXEmacs + +@end itemize + @item Installation changes @itemize @bullet @@ -55,6 +66,11 @@ @itemize @bullet +@item New version of @code{nnimap} + +@code{nnimap} has been reimplemented in a mostly-compatible way. +@c Mention any incompatibilities. + @item Gnus includes the Emacs Lisp @acronym{SASL} library. This provides a clean @acronym{API} to @acronym{SASL} mechanisms from
--- a/doc/misc/gnus.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/gnus.texi Wed Sep 22 15:46:51 2010 +0900 @@ -9838,6 +9838,9 @@ can use include: @table @code +@item gnus-article-html +Use Gnus rendered based on w3m. + @item w3 Use Emacs/W3. @@ -18381,7 +18384,7 @@ @cindex expunge @cindex manual expunging @kindex G x (Group) -@findex gnus-group-nnimap-expunge +@findex gnus-group-expunge-group If you're using the @code{never} setting of @code{nnimap-expunge-on-close}, you may want the option of expunging all deleted articles in a mailbox @@ -29672,7 +29675,7 @@ on successful article retrieval. -@item (nnchoke-request-group GROUP &optional SERVER FAST) +@item (nnchoke-request-group GROUP &optional SERVER FAST INFO) Get data on @var{group}. This function also has the side effect of making @var{group} the current group. @@ -29680,6 +29683,9 @@ If @var{fast}, don't bother to return useful data, just make @var{group} the current group. +If @var{info}, it allows the backend to update the group info +structure. + Here's an example of some result data and a definition of the same: @example
--- a/doc/misc/org.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/org.texi Wed Sep 22 15:46:51 2010 +0900 @@ -51,7 +51,8 @@ @copying This manual is for Org version @value{VERSION}. -Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation +Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010 +Free Software Foundation, Inc. @quotation Permission is granted to copy, distribute and/or modify this document @@ -101,400 +102,400 @@ @end ifnottex @menu -* Introduction:: Getting started -* Document Structure:: A tree works like your brain -* Tables:: Pure magic for quick formatting -* Hyperlinks:: Notes in context -* TODO Items:: Every tree branch can be a TODO item -* Tags:: Tagging headlines and matching sets of tags -* Properties and Columns:: Storing information about an entry -* Dates and Times:: Making items useful for planning -* Capture - Refile - Archive:: The ins and outs for projects -* Agenda Views:: Collecting information into views -* Markup:: Prepare text for rich export -* Exporting:: Sharing and publishing of notes -* Publishing:: Create a web site of linked Org files -* Working With Source Code:: Export, evaluate, and tangle code blocks -* Miscellaneous:: All the rest which did not fit elsewhere -* Hacking:: How to hack your way around -* MobileOrg:: Viewing and capture on a mobile device -* History and Acknowledgments:: How Org came into being -* Main Index:: An index of Org's concepts and features -* Key Index:: Key bindings and where they are described -* Variable Index:: Variables mentioned in the manual +* Introduction:: Getting started +* Document Structure:: A tree works like your brain +* Tables:: Pure magic for quick formatting +* Hyperlinks:: Notes in context +* TODO Items:: Every tree branch can be a TODO item +* Tags:: Tagging headlines and matching sets of tags +* Properties and Columns:: Storing information about an entry +* Dates and Times:: Making items useful for planning +* Capture - Refile - Archive:: The ins and outs for projects +* Agenda Views:: Collecting information into views +* Markup:: Prepare text for rich export +* Exporting:: Sharing and publishing of notes +* Publishing:: Create a web site of linked Org files +* Working With Source Code:: Export, evaluate, and tangle code blocks +* Miscellaneous:: All the rest which did not fit elsewhere +* Hacking:: How to hack your way around +* MobileOrg:: Viewing and capture on a mobile device +* History and Acknowledgments:: How Org came into being +* Main Index:: An index of Org's concepts and features +* Key Index:: Key bindings and where they are described +* Variable Index:: Variables mentioned in the manual @detailmenu --- The Detailed Node Listing --- Introduction -* Summary:: Brief summary of what Org does -* Installation:: How to install a downloaded version of Org -* Activation:: How to activate Org for certain buffers -* Feedback:: Bug reports, ideas, patches etc. -* Conventions:: Type-setting conventions in the manual +* Summary:: Brief summary of what Org does +* Installation:: How to install a downloaded version of Org +* Activation:: How to activate Org for certain buffers +* Feedback:: Bug reports, ideas, patches etc. +* Conventions:: Type-setting conventions in the manual Document structure -* Outlines:: Org is based on Outline mode -* Headlines:: How to typeset Org tree headlines -* Visibility cycling:: Show and hide, much simplified -* Motion:: Jumping to other headlines -* Structure editing:: Changing sequence and level of headlines -* Sparse trees:: Matches embedded in context -* Plain lists:: Additional structure within an entry -* Drawers:: Tucking stuff away -* Blocks:: Folding blocks -* Footnotes:: How footnotes are defined in Org's syntax -* Orgstruct mode:: Structure editing outside Org +* Outlines:: Org is based on Outline mode +* Headlines:: How to typeset Org tree headlines +* Visibility cycling:: Show and hide, much simplified +* Motion:: Jumping to other headlines +* Structure editing:: Changing sequence and level of headlines +* Sparse trees:: Matches embedded in context +* Plain lists:: Additional structure within an entry +* Drawers:: Tucking stuff away +* Blocks:: Folding blocks +* Footnotes:: How footnotes are defined in Org's syntax +* Orgstruct mode:: Structure editing outside Org Tables -* Built-in table editor:: Simple tables -* Column width and alignment:: Overrule the automatic settings -* Column groups:: Grouping to trigger vertical lines -* Orgtbl mode:: The table editor as minor mode -* The spreadsheet:: The table editor has spreadsheet capabilities -* Org-Plot:: Plotting from org tables +* Built-in table editor:: Simple tables +* Column width and alignment:: Overrule the automatic settings +* Column groups:: Grouping to trigger vertical lines +* Orgtbl mode:: The table editor as minor mode +* The spreadsheet:: The table editor has spreadsheet capabilities +* Org-Plot:: Plotting from org tables The spreadsheet -* References:: How to refer to another field or range -* Formula syntax for Calc:: Using Calc to compute stuff -* Formula syntax for Lisp:: Writing formulas in Emacs Lisp -* Field formulas:: Formulas valid for a single field -* Column formulas:: Formulas valid for an entire column +* References:: How to refer to another field or range +* Formula syntax for Calc:: Using Calc to compute stuff +* Formula syntax for Lisp:: Writing formulas in Emacs Lisp +* Field formulas:: Formulas valid for a single field +* Column formulas:: Formulas valid for an entire column * Editing and debugging formulas:: Fixing formulas -* Updating the table:: Recomputing all dependent fields -* Advanced features:: Field names, parameters and automatic recalc +* Updating the table:: Recomputing all dependent fields +* Advanced features:: Field names, parameters and automatic recalc Hyperlinks -* Link format:: How links in Org are formatted -* Internal links:: Links to other places in the current file -* External links:: URL-like links to the world -* Handling links:: Creating, inserting and following -* Using links outside Org:: Linking from my C source code? -* Link abbreviations:: Shortcuts for writing complex links -* Search options:: Linking to a specific location -* Custom searches:: When the default search is not enough +* Link format:: How links in Org are formatted +* Internal links:: Links to other places in the current file +* External links:: URL-like links to the world +* Handling links:: Creating, inserting and following +* Using links outside Org:: Linking from my C source code? +* Link abbreviations:: Shortcuts for writing complex links +* Search options:: Linking to a specific location +* Custom searches:: When the default search is not enough Internal links -* Radio targets:: Make targets trigger links in plain text +* Radio targets:: Make targets trigger links in plain text TODO items -* TODO basics:: Marking and displaying TODO entries -* TODO extensions:: Workflow and assignments -* Progress logging:: Dates and notes for progress -* Priorities:: Some things are more important than others -* Breaking down tasks:: Splitting a task into manageable pieces -* Checkboxes:: Tick-off lists +* TODO basics:: Marking and displaying TODO entries +* TODO extensions:: Workflow and assignments +* Progress logging:: Dates and notes for progress +* Priorities:: Some things are more important than others +* Breaking down tasks:: Splitting a task into manageable pieces +* Checkboxes:: Tick-off lists Extended use of TODO keywords -* Workflow states:: From TODO to DONE in steps -* TODO types:: I do this, Fred does the rest -* Multiple sets in one file:: Mixing it all, and still finding your way -* Fast access to TODO states:: Single letter selection of a state -* Per-file keywords:: Different files, different requirements -* Faces for TODO keywords:: Highlighting states -* TODO dependencies:: When one task needs to wait for others +* Workflow states:: From TODO to DONE in steps +* TODO types:: I do this, Fred does the rest +* Multiple sets in one file:: Mixing it all, and still finding your way +* Fast access to TODO states:: Single letter selection of a state +* Per-file keywords:: Different files, different requirements +* Faces for TODO keywords:: Highlighting states +* TODO dependencies:: When one task needs to wait for others Progress logging -* Closing items:: When was this entry marked DONE? -* Tracking TODO state changes:: When did the status change? -* Tracking your habits:: How consistent have you been? +* Closing items:: When was this entry marked DONE? +* Tracking TODO state changes:: When did the status change? +* Tracking your habits:: How consistent have you been? Tags -* Tag inheritance:: Tags use the tree structure of the outline -* Setting tags:: How to assign tags to a headline -* Tag searches:: Searching for combinations of tags +* Tag inheritance:: Tags use the tree structure of the outline +* Setting tags:: How to assign tags to a headline +* Tag searches:: Searching for combinations of tags Properties and columns -* Property syntax:: How properties are spelled out -* Special properties:: Access to other Org-mode features -* Property searches:: Matching property values -* Property inheritance:: Passing values down the tree -* Column view:: Tabular viewing and editing -* Property API:: Properties for Lisp programmers +* Property syntax:: How properties are spelled out +* Special properties:: Access to other Org-mode features +* Property searches:: Matching property values +* Property inheritance:: Passing values down the tree +* Column view:: Tabular viewing and editing +* Property API:: Properties for Lisp programmers Column view -* Defining columns:: The COLUMNS format property -* Using column view:: How to create and use column view -* Capturing column view:: A dynamic block for column view +* Defining columns:: The COLUMNS format property +* Using column view:: How to create and use column view +* Capturing column view:: A dynamic block for column view Defining columns -* Scope of column definitions:: Where defined, where valid? -* Column attributes:: Appearance and content of a column +* Scope of column definitions:: Where defined, where valid? +* Column attributes:: Appearance and content of a column Dates and times -* Timestamps:: Assigning a time to a tree entry -* Creating timestamps:: Commands which insert timestamps -* Deadlines and scheduling:: Planning your work -* Clocking work time:: Tracking how long you spend on a task -* Resolving idle time:: Resolving time if you've been idle -* Effort estimates:: Planning work effort in advance -* Relative timer:: Notes with a running timer +* Timestamps:: Assigning a time to a tree entry +* Creating timestamps:: Commands which insert timestamps +* Deadlines and scheduling:: Planning your work +* Clocking work time:: Tracking how long you spend on a task +* Resolving idle time:: Resolving time if you've been idle +* Effort estimates:: Planning work effort in advance +* Relative timer:: Notes with a running timer Creating timestamps -* The date/time prompt:: How Org-mode helps you entering date and time -* Custom time format:: Making dates look different +* The date/time prompt:: How Org-mode helps you entering date and time +* Custom time format:: Making dates look different Deadlines and scheduling -* Inserting deadline/schedule:: Planning items -* Repeated tasks:: Items that show up again and again +* Inserting deadline/schedule:: Planning items +* Repeated tasks:: Items that show up again and again Capture - Refile - Archive -* Capture:: Capturing new stuff -* Attachments:: Add files to tasks -* RSS Feeds:: Getting input from RSS feeds -* Protocols:: External (e.g. Browser) access to Emacs and Org -* Refiling notes:: Moving a tree from one place to another -* Archiving:: What to do with finished projects +* Capture:: Capturing new stuff +* Attachments:: Add files to tasks +* RSS Feeds:: Getting input from RSS feeds +* Protocols:: External (e.g. Browser) access to Emacs and Org +* Refiling notes:: Moving a tree from one place to another +* Archiving:: What to do with finished projects Capture -* Setting up capture:: Where notes will be stored -* Using capture:: Commands to invoke and terminate capture -* Capture templates:: Define the outline of different note types +* Setting up capture:: Where notes will be stored +* Using capture:: Commands to invoke and terminate capture +* Capture templates:: Define the outline of different note types Capture templates -* Template elements:: What is needed for a complete template entry -* Template expansion:: Filling in information about time and context +* Template elements:: What is needed for a complete template entry +* Template expansion:: Filling in information about time and context Archiving -* Moving subtrees:: Moving a tree to an archive file -* Internal archiving:: Switch off a tree but keep it in the file +* Moving subtrees:: Moving a tree to an archive file +* Internal archiving:: Switch off a tree but keep it in the file Agenda views -* Agenda files:: Files being searched for agenda information -* Agenda dispatcher:: Keyboard access to agenda views -* Built-in agenda views:: What is available out of the box? -* Presentation and sorting:: How agenda items are prepared for display -* Agenda commands:: Remote editing of Org trees -* Custom agenda views:: Defining special searches and views -* Exporting Agenda Views:: Writing a view to a file -* Agenda column view:: Using column view for collected entries +* Agenda files:: Files being searched for agenda information +* Agenda dispatcher:: Keyboard access to agenda views +* Built-in agenda views:: What is available out of the box? +* Presentation and sorting:: How agenda items are prepared for display +* Agenda commands:: Remote editing of Org trees +* Custom agenda views:: Defining special searches and views +* Exporting Agenda Views:: Writing a view to a file +* Agenda column view:: Using column view for collected entries The built-in agenda views -* Weekly/daily agenda:: The calendar page with current tasks -* Global TODO list:: All unfinished action items +* Weekly/daily agenda:: The calendar page with current tasks +* Global TODO list:: All unfinished action items * Matching tags and properties:: Structured information with fine-tuned search -* Timeline:: Time-sorted view for single file -* Search view:: Find entries by searching for text -* Stuck projects:: Find projects you need to review +* Timeline:: Time-sorted view for single file +* Search view:: Find entries by searching for text +* Stuck projects:: Find projects you need to review Presentation and sorting -* Categories:: Not all tasks are equal -* Time-of-day specifications:: How the agenda knows the time -* Sorting of agenda items:: The order of things +* Categories:: Not all tasks are equal +* Time-of-day specifications:: How the agenda knows the time +* Sorting of agenda items:: The order of things Custom agenda views -* Storing searches:: Type once, use often -* Block agenda:: All the stuff you need in a single buffer -* Setting Options:: Changing the rules +* Storing searches:: Type once, use often +* Block agenda:: All the stuff you need in a single buffer +* Setting Options:: Changing the rules Markup for rich export -* Structural markup elements:: The basic structure as seen by the exporter -* Images and tables:: Tables and Images will be included -* Literal examples:: Source code examples with special formatting -* Include files:: Include additional files into a document -* Index entries:: Making an index -* Macro replacement:: Use macros to create complex output -* Embedded LaTeX:: LaTeX can be freely used inside Org documents +* Structural markup elements:: The basic structure as seen by the exporter +* Images and tables:: Tables and Images will be included +* Literal examples:: Source code examples with special formatting +* Include files:: Include additional files into a document +* Index entries:: Making an index +* Macro replacement:: Use macros to create complex output +* Embedded LaTeX:: LaTeX can be freely used inside Org documents Structural markup elements -* Document title:: Where the title is taken from -* Headings and sections:: The document structure as seen by the exporter -* Table of contents:: The if and where of the table of contents -* Initial text:: Text before the first heading? -* Lists:: Lists -* Paragraphs:: Paragraphs -* Footnote markup:: Footnotes -* Emphasis and monospace:: Bold, italic, etc. -* Horizontal rules:: Make a line -* Comment lines:: What will *not* be exported +* Document title:: Where the title is taken from +* Headings and sections:: The document structure as seen by the exporter +* Table of contents:: The if and where of the table of contents +* Initial text:: Text before the first heading? +* Lists:: Lists +* Paragraphs:: Paragraphs +* Footnote markup:: Footnotes +* Emphasis and monospace:: Bold, italic, etc. +* Horizontal rules:: Make a line +* Comment lines:: What will *not* be exported Embedded La@TeX{} -* Special symbols:: Greek letters and other symbols -* Subscripts and superscripts:: Simple syntax for raising/lowering text -* LaTeX fragments:: Complex formulas made easy -* Previewing LaTeX fragments:: What will this snippet look like? -* CDLaTeX mode:: Speed up entering of formulas +* Special symbols:: Greek letters and other symbols +* Subscripts and superscripts:: Simple syntax for raising/lowering text +* LaTeX fragments:: Complex formulas made easy +* Previewing LaTeX fragments:: What will this snippet look like? +* CDLaTeX mode:: Speed up entering of formulas Exporting -* Selective export:: Using tags to select and exclude trees -* Export options:: Per-file export settings -* The export dispatcher:: How to access exporter commands -* ASCII/Latin-1/UTF-8 export:: Exporting to flat files with encoding -* HTML export:: Exporting to HTML -* LaTeX and PDF export:: Exporting to La@TeX{}, and processing to PDF -* DocBook export:: Exporting to DocBook -* TaskJuggler export:: Exporting to TaskJuggler -* Freemind export:: Exporting to Freemind mind maps -* XOXO export:: Exporting to XOXO -* iCalendar export:: Exporting in iCalendar format +* Selective export:: Using tags to select and exclude trees +* Export options:: Per-file export settings +* The export dispatcher:: How to access exporter commands +* ASCII/Latin-1/UTF-8 export:: Exporting to flat files with encoding +* HTML export:: Exporting to HTML +* LaTeX and PDF export:: Exporting to La@TeX{}, and processing to PDF +* DocBook export:: Exporting to DocBook +* TaskJuggler export:: Exporting to TaskJuggler +* Freemind export:: Exporting to Freemind mind maps +* XOXO export:: Exporting to XOXO +* iCalendar export:: Exporting in iCalendar format HTML export -* HTML Export commands:: How to invoke HTML export -* Quoting HTML tags:: Using direct HTML in Org-mode -* Links in HTML export:: How links will be interpreted and formatted -* Tables in HTML export:: How to modify the formatting of tables -* Images in HTML export:: How to insert figures into HTML output -* Text areas in HTML export:: An alternative way to show an example -* CSS support:: Changing the appearance of the output -* JavaScript support:: Info and Folding in a web browser +* HTML Export commands:: How to invoke HTML export +* Quoting HTML tags:: Using direct HTML in Org-mode +* Links in HTML export:: How links will be interpreted and formatted +* Tables in HTML export:: How to modify the formatting of tables +* Images in HTML export:: How to insert figures into HTML output +* Text areas in HTML export:: An alternative way to show an example +* CSS support:: Changing the appearance of the output +* JavaScript support:: Info and Folding in a web browser La@TeX{} and PDF export -* LaTeX/PDF export commands:: Which key invokes which commands -* Header and sectioning:: Setting up the export file structure -* Quoting LaTeX code:: Incorporating literal La@TeX{} code -* Tables in LaTeX export:: Options for exporting tables to La@TeX{} -* Images in LaTeX export:: How to insert figures into La@TeX{} output -* Beamer class export:: Turning the file into a presentation +* LaTeX/PDF export commands:: Which key invokes which commands +* Header and sectioning:: Setting up the export file structure +* Quoting LaTeX code:: Incorporating literal La@TeX{} code +* Tables in LaTeX export:: Options for exporting tables to La@TeX{} +* Images in LaTeX export:: How to insert figures into La@TeX{} output +* Beamer class export:: Turning the file into a presentation DocBook export -* DocBook export commands:: How to invoke DocBook export -* Quoting DocBook code:: Incorporating DocBook code in Org files -* Recursive sections:: Recursive sections in DocBook -* Tables in DocBook export:: Tables are exported as HTML tables -* Images in DocBook export:: How to insert figures into DocBook output -* Special characters:: How to handle special characters +* DocBook export commands:: How to invoke DocBook export +* Quoting DocBook code:: Incorporating DocBook code in Org files +* Recursive sections:: Recursive sections in DocBook +* Tables in DocBook export:: Tables are exported as HTML tables +* Images in DocBook export:: How to insert figures into DocBook output +* Special characters:: How to handle special characters Publishing -* Configuration:: Defining projects -* Uploading files:: How to get files up on the server -* Sample configuration:: Example projects -* Triggering publication:: Publication commands +* Configuration:: Defining projects +* Uploading files:: How to get files up on the server +* Sample configuration:: Example projects +* Triggering publication:: Publication commands Configuration -* Project alist:: The central configuration variable -* Sources and destinations:: From here to there -* Selecting files:: What files are part of the project? -* Publishing action:: Setting the function doing the publishing -* Publishing options:: Tweaking HTML export -* Publishing links:: Which links keep working after publishing? -* Sitemap:: Generating a list of all pages -* Generating an index:: An index that reaches across pages +* Project alist:: The central configuration variable +* Sources and destinations:: From here to there +* Selecting files:: What files are part of the project? +* Publishing action:: Setting the function doing the publishing +* Publishing options:: Tweaking HTML export +* Publishing links:: Which links keep working after publishing? +* Sitemap:: Generating a list of all pages +* Generating an index:: An index that reaches across pages Sample configuration -* Simple example:: One-component publishing -* Complex example:: A multi-component publishing example +* Simple example:: One-component publishing +* Complex example:: A multi-component publishing example Working with source code -* Structure of code blocks:: Code block syntax described -* Editing source code:: Language major-mode editing -* Exporting code blocks:: Export contents and/or results -* Extracting source code:: Create pure source code files -* Evaluating code blocks:: Place results of evaluation in the Org-mode buffer -* Library of Babel:: Use and contribute to a library of useful code blocks -* Languages:: List of supported code block languages -* Header arguments:: Configure code block functionality -* Results of evaluation:: How evaluation results are handled -* Noweb reference syntax:: Literate programming in Org-mode +* Structure of code blocks:: Code block syntax described +* Editing source code:: Language major-mode editing +* Exporting code blocks:: Export contents and/or results +* Extracting source code:: Create pure source code files +* Evaluating code blocks:: Place results of evaluation in the Org-mode buffer +* Library of Babel:: Use and contribute to a library of useful code blocks +* Languages:: List of supported code block languages +* Header arguments:: Configure code block functionality +* Results of evaluation:: How evaluation results are handled +* Noweb reference syntax:: Literate programming in Org-mode * Key bindings and useful functions:: Work quickly with code blocks -* Batch execution:: Call functions from the command line +* Batch execution:: Call functions from the command line Header arguments -* Using header arguments:: Different ways to set header arguments -* Specific header arguments:: List of header arguments +* Using header arguments:: Different ways to set header arguments +* Specific header arguments:: List of header arguments Using header arguments * System-wide header arguments:: Set global default values -* Language-specific header arguments:: Set default values by language +* Language-specific header arguments:: Set default values by language * Buffer-wide header arguments:: Set default values for a specific buffer * Header arguments in Org-mode properties:: Set default values for a buffer or heading * Code block specific header arguments:: The most common way to set values Specific header arguments -* var:: Pass arguments to code blocks -* results:: Specify the type of results and how they will be collected and handled -* file:: Specify a path for file output -* dir:: Specify the default directory for code block execution -* exports:: Export code and/or results -* tangle:: Toggle tangling and specify file name -* no-expand:: Turn off variable assignment and noweb expansion during tangling -* session:: Preserve the state of code evaluation -* noweb:: Toggle expansion of noweb references -* cache:: Avoid re-evaluating unchanged code blocks -* hlines:: Handle horizontal lines in tables -* colnames:: Handle column names in tables -* rownames:: Handle row names in tables -* shebang:: Make tangled files executable +* var:: Pass arguments to code blocks +* results:: Specify the type of results and how they will be collected and handled +* file:: Specify a path for file output +* dir:: Specify the default directory for code block execution +* exports:: Export code and/or results +* tangle:: Toggle tangling and specify file name +* no-expand:: Turn off variable assignment and noweb expansion during tangling +* session:: Preserve the state of code evaluation +* noweb:: Toggle expansion of noweb references +* cache:: Avoid re-evaluating unchanged code blocks +* hlines:: Handle horizontal lines in tables +* colnames:: Handle column names in tables +* rownames:: Handle row names in tables +* shebang:: Make tangled files executable Miscellaneous -* Completion:: M-TAB knows what you need -* Speed keys:: Electric commands at the beginning of a headline -* Code evaluation security:: Org mode files evaluate inline code -* Customization:: Adapting Org to your taste -* In-buffer settings:: Overview of the #+KEYWORDS -* The very busy C-c C-c key:: When in doubt, press C-c C-c -* Clean view:: Getting rid of leading stars in the outline -* TTY keys:: Using Org on a tty -* Interaction:: Other Emacs packages +* Completion:: M-TAB knows what you need +* Speed keys:: Electric commands at the beginning of a headline +* Code evaluation security:: Org mode files evaluate inline code +* Customization:: Adapting Org to your taste +* In-buffer settings:: Overview of the #+KEYWORDS +* The very busy C-c C-c key:: When in doubt, press C-c C-c +* Clean view:: Getting rid of leading stars in the outline +* TTY keys:: Using Org on a tty +* Interaction:: Other Emacs packages Interaction with other packages -* Cooperation:: Packages Org cooperates with -* Conflicts:: Packages that lead to conflicts +* Cooperation:: Packages Org cooperates with +* Conflicts:: Packages that lead to conflicts Hacking -* Hooks:: Who to reach into Org's internals -* Add-on packages:: Available extensions -* Adding hyperlink types:: New custom link types -* Context-sensitive commands:: How to add functionality to such commands -* Tables in arbitrary syntax:: Orgtbl for La@TeX{} and other programs -* Dynamic blocks:: Automatically filled blocks -* Special agenda views:: Customized views +* Hooks:: Who to reach into Org's internals +* Add-on packages:: Available extensions +* Adding hyperlink types:: New custom link types +* Context-sensitive commands:: How to add functionality to such commands +* Tables in arbitrary syntax:: Orgtbl for La@TeX{} and other programs +* Dynamic blocks:: Automatically filled blocks +* Special agenda views:: Customized views * Extracting agenda information:: Postprocessing of agenda information -* Using the property API:: Writing programs that use entry properties -* Using the mapping API:: Mapping over all or selected entries +* Using the property API:: Writing programs that use entry properties +* Using the mapping API:: Mapping over all or selected entries Tables and lists in arbitrary syntax -* Radio tables:: Sending and receiving radio tables -* A LaTeX example:: Step by step, almost a tutorial -* Translator functions:: Copy and modify -* Radio lists:: Doing the same for lists +* Radio tables:: Sending and receiving radio tables +* A LaTeX example:: Step by step, almost a tutorial +* Translator functions:: Copy and modify +* Radio lists:: Doing the same for lists MobileOrg -* Setting up the staging area:: Where to interact with the mobile device -* Pushing to MobileOrg:: Uploading Org files and agendas -* Pulling from MobileOrg:: Integrating captured and flagged items +* Setting up the staging area:: Where to interact with the mobile device +* Pushing to MobileOrg:: Uploading Org files and agendas +* Pulling from MobileOrg:: Integrating captured and flagged items @end detailmenu @end menu @@ -504,11 +505,11 @@ @cindex introduction @menu -* Summary:: Brief summary of what Org does -* Installation:: How to install a downloaded version of Org -* Activation:: How to activate Org for certain buffers -* Feedback:: Bug reports, ideas, patches etc. -* Conventions:: Type-setting conventions in the manual +* Summary:: Brief summary of what Org does +* Installation:: How to install a downloaded version of Org +* Activation:: How to activate Org for certain buffers +* Feedback:: Bug reports, ideas, patches etc. +* Conventions:: Type-setting conventions in the manual @end menu @node Summary, Installation, Introduction, Introduction @@ -805,17 +806,17 @@ edit the structure of the document. @menu -* Outlines:: Org is based on Outline mode -* Headlines:: How to typeset Org tree headlines -* Visibility cycling:: Show and hide, much simplified -* Motion:: Jumping to other headlines -* Structure editing:: Changing sequence and level of headlines -* Sparse trees:: Matches embedded in context -* Plain lists:: Additional structure within an entry -* Drawers:: Tucking stuff away -* Blocks:: Folding blocks -* Footnotes:: How footnotes are defined in Org's syntax -* Orgstruct mode:: Structure editing outside Org +* Outlines:: Org is based on Outline mode +* Headlines:: How to typeset Org tree headlines +* Visibility cycling:: Show and hide, much simplified +* Motion:: Jumping to other headlines +* Structure editing:: Changing sequence and level of headlines +* Sparse trees:: Matches embedded in context +* Plain lists:: Additional structure within an entry +* Drawers:: Tucking stuff away +* Blocks:: Folding blocks +* Footnotes:: How footnotes are defined in Org's syntax +* Orgstruct mode:: Structure editing outside Org @end menu @node Outlines, Headlines, Document Structure, Document Structure @@ -1640,12 +1641,12 @@ @end ifnotinfo @menu -* Built-in table editor:: Simple tables -* Column width and alignment:: Overrule the automatic settings -* Column groups:: Grouping to trigger vertical lines -* Orgtbl mode:: The table editor as minor mode -* The spreadsheet:: The table editor has spreadsheet capabilities -* Org-Plot:: Plotting from org tables +* Built-in table editor:: Simple tables +* Column width and alignment:: Overrule the automatic settings +* Column groups:: Grouping to trigger vertical lines +* Orgtbl mode:: The table editor as minor mode +* The spreadsheet:: The table editor has spreadsheet capabilities +* Org-Plot:: Plotting from org tables @end menu @node Built-in table editor, Column width and alignment, Tables, Tables @@ -2019,14 +2020,14 @@ formula, moving these references by arrow keys @menu -* References:: How to refer to another field or range -* Formula syntax for Calc:: Using Calc to compute stuff -* Formula syntax for Lisp:: Writing formulas in Emacs Lisp -* Field formulas:: Formulas valid for a single field -* Column formulas:: Formulas valid for an entire column +* References:: How to refer to another field or range +* Formula syntax for Calc:: Using Calc to compute stuff +* Formula syntax for Lisp:: Writing formulas in Emacs Lisp +* Field formulas:: Formulas valid for a single field +* Column formulas:: Formulas valid for an entire column * Editing and debugging formulas:: Fixing formulas -* Updating the table:: Recomputing all dependent fields -* Advanced features:: Field names, parameters and automatic recalc +* Updating the table:: Recomputing all dependent fields +* Advanced features:: Field names, parameters and automatic recalc @end menu @node References, Formula syntax for Calc, The spreadsheet, The spreadsheet @@ -2730,14 +2731,14 @@ other files, Usenet articles, emails, and much more. @menu -* Link format:: How links in Org are formatted -* Internal links:: Links to other places in the current file -* External links:: URL-like links to the world -* Handling links:: Creating, inserting and following -* Using links outside Org:: Linking from my C source code? -* Link abbreviations:: Shortcuts for writing complex links -* Search options:: Linking to a specific location -* Custom searches:: When the default search is not enough +* Link format:: How links in Org are formatted +* Internal links:: Links to other places in the current file +* External links:: URL-like links to the world +* Handling links:: Creating, inserting and following +* Using links outside Org:: Linking from my C source code? +* Link abbreviations:: Shortcuts for writing complex links +* Search options:: Linking to a specific location +* Custom searches:: When the default search is not enough @end menu @node Link format, Internal links, Hyperlinks, Hyperlinks @@ -2830,7 +2831,7 @@ earlier. @menu -* Radio targets:: Make targets trigger links in plain text +* Radio targets:: Make targets trigger links in plain text @end menu @node Radio targets, , Internal links, Internal links @@ -3285,12 +3286,12 @@ methods to give you an overview of all the things that you have to do. @menu -* TODO basics:: Marking and displaying TODO entries -* TODO extensions:: Workflow and assignments -* Progress logging:: Dates and notes for progress -* Priorities:: Some things are more important than others -* Breaking down tasks:: Splitting a task into manageable pieces -* Checkboxes:: Tick-off lists +* TODO basics:: Marking and displaying TODO entries +* TODO extensions:: Workflow and assignments +* Progress logging:: Dates and notes for progress +* Priorities:: Some things are more important than others +* Breaking down tasks:: Splitting a task into manageable pieces +* Checkboxes:: Tick-off lists @end menu @node TODO basics, TODO extensions, TODO Items, TODO Items @@ -3382,13 +3383,13 @@ TODO items in particular (@pxref{Tags}). @menu -* Workflow states:: From TODO to DONE in steps -* TODO types:: I do this, Fred does the rest -* Multiple sets in one file:: Mixing it all, and still finding your way -* Fast access to TODO states:: Single letter selection of a state -* Per-file keywords:: Different files, different requirements -* Faces for TODO keywords:: Highlighting states -* TODO dependencies:: When one task needs to wait for others +* Workflow states:: From TODO to DONE in steps +* TODO types:: I do this, Fred does the rest +* Multiple sets in one file:: Mixing it all, and still finding your way +* Fast access to TODO states:: Single letter selection of a state +* Per-file keywords:: Different files, different requirements +* Faces for TODO keywords:: Highlighting states +* TODO dependencies:: When one task needs to wait for others @end menu @node Workflow states, TODO types, TODO extensions, TODO extensions @@ -3679,9 +3680,9 @@ work time}. @menu -* Closing items:: When was this entry marked DONE? -* Tracking TODO state changes:: When did the status change? -* Tracking your habits:: How consistent have you been? +* Closing items:: When was this entry marked DONE? +* Tracking TODO state changes:: When did the status change? +* Tracking your habits:: How consistent have you been? @end menu @node Closing items, Tracking TODO state changes, Progress logging, Progress logging @@ -4143,9 +4144,9 @@ (@pxref{Faces for TODO keywords}). @menu -* Tag inheritance:: Tags use the tree structure of the outline -* Setting tags:: How to assign tags to a headline -* Tag searches:: Searching for combinations of tags +* Tag inheritance:: Tags use the tree structure of the outline +* Setting tags:: How to assign tags to a headline +* Tag searches:: Searching for combinations of tags @end menu @node Tag inheritance, Setting tags, Tags, Tags @@ -4432,12 +4433,12 @@ (@pxref{Column view}). @menu -* Property syntax:: How properties are spelled out -* Special properties:: Access to other Org-mode features -* Property searches:: Matching property values -* Property inheritance:: Passing values down the tree -* Column view:: Tabular viewing and editing -* Property API:: Properties for Lisp programmers +* Property syntax:: How properties are spelled out +* Special properties:: Access to other Org-mode features +* Property searches:: Matching property values +* Property inheritance:: Passing values down the tree +* Column view:: Tabular viewing and editing +* Property API:: Properties for Lisp programmers @end menu @node Property syntax, Special properties, Properties and Columns, Properties and Columns @@ -4673,9 +4674,9 @@ queries have collected selected items, possibly from a number of files. @menu -* Defining columns:: The COLUMNS format property -* Using column view:: How to create and use column view -* Capturing column view:: A dynamic block for column view +* Defining columns:: The COLUMNS format property +* Using column view:: How to create and use column view +* Capturing column view:: A dynamic block for column view @end menu @node Defining columns, Using column view, Column view, Column view @@ -4687,8 +4688,8 @@ done by defining a column format line. @menu -* Scope of column definitions:: Where defined, where valid? -* Column attributes:: Appearance and content of a column +* Scope of column definitions:: Where defined, where valid? +* Column attributes:: Appearance and content of a column @end menu @node Scope of column definitions, Column attributes, Defining columns, Defining columns @@ -4770,7 +4771,7 @@ @example :COLUMNS: %25ITEM %9Approved(Approved?)@{X@} %Owner %11Status \@footnote{Please note that the COLUMNS definition must be on a single line---it is wrapped here only because of formatting constraints.} - %10Time_Estimate@{:@} %CLOCKSUM + %10Time_Estimate@{:@} %CLOCKSUM :Owner_ALL: Tammy Mark Karl Lisa Don :Status_ALL: "In progress" "Not started yet" "Finished" "" :Approved_ALL: "[ ]" "[X]" @@ -4970,13 +4971,13 @@ is used in a much wider sense. @menu -* Timestamps:: Assigning a time to a tree entry -* Creating timestamps:: Commands which insert timestamps -* Deadlines and scheduling:: Planning your work -* Clocking work time:: Tracking how long you spend on a task -* Resolving idle time:: Resolving time if you've been idle -* Effort estimates:: Planning work effort in advance -* Relative timer:: Notes with a running timer +* Timestamps:: Assigning a time to a tree entry +* Creating timestamps:: Commands which insert timestamps +* Deadlines and scheduling:: Planning your work +* Clocking work time:: Tracking how long you spend on a task +* Resolving idle time:: Resolving time if you've been idle +* Effort estimates:: Planning work effort in advance +* Relative timer:: Notes with a running timer @end menu @@ -5132,8 +5133,8 @@ @menu -* The date/time prompt:: How Org-mode helps you entering date and time -* Custom time format:: Making dates look different +* The date/time prompt:: How Org-mode helps you entering date and time +* Custom time format:: Making dates look different @end menu @node The date/time prompt, Custom time format, Creating timestamps, Creating timestamps @@ -5365,8 +5366,8 @@ sexp entry matches. @menu -* Inserting deadline/schedule:: Planning items -* Repeated tasks:: Items that show up again and again +* Inserting deadline/schedule:: Planning items +* Repeated tasks:: Items that show up again and again @end menu @node Inserting deadline/schedule, Repeated tasks, Deadlines and scheduling, Deadlines and scheduling @@ -5888,12 +5889,12 @@ trees to an archive file keeps the system compact and fast. @menu -* Capture:: Capturing new stuff -* Attachments:: Add files to tasks -* RSS Feeds:: Getting input from RSS feeds -* Protocols:: External (e.g. Browser) access to Emacs and Org -* Refiling notes:: Moving a tree from one place to another -* Archiving:: What to do with finished projects +* Capture:: Capturing new stuff +* Attachments:: Add files to tasks +* RSS Feeds:: Getting input from RSS feeds +* Protocols:: External (e.g. Browser) access to Emacs and Org +* Refiling notes:: Moving a tree from one place to another +* Archiving:: What to do with finished projects @end menu @node Capture, Attachments, Capture - Refile - Archive, Capture - Refile - Archive @@ -5921,9 +5922,9 @@ does enhance it with templates and more. @menu -* Setting up capture:: Where notes will be stored -* Using capture:: Commands to invoke and terminate capture -* Capture templates:: Define the outline of different note types +* Setting up capture:: Where notes will be stored +* Using capture:: Commands to invoke and terminate capture +* Capture templates:: Define the outline of different note types @end menu @node Setting up capture, Using capture, Capture, Capture @@ -6016,8 +6017,8 @@ @menu -* Template elements:: What is needed for a complete template entry -* Template expansion:: Filling in information about time and context +* Template elements:: What is needed for a complete template entry +* Template expansion:: Filling in information about time and context @end menu @node Template elements, Template expansion, Capture templates, Capture templates @@ -6326,8 +6327,8 @@ @example (setq org-feed-alist '(("Slashdot" - "http://rss.slashdot.org/Slashdot/slashdot" - "~/txt/org/feeds.org" "Slashdot Entries"))) + "http://rss.slashdot.org/Slashdot/slashdot" + "~/txt/org/feeds.org" "Slashdot Entries"))) @end example @noindent @@ -6440,8 +6441,8 @@ @end table @menu -* Moving subtrees:: Moving a tree to an archive file -* Internal archiving:: Switch off a tree but keep it in the file +* Moving subtrees:: Moving a tree to an archive file +* Internal archiving:: Switch off a tree but keep it in the file @end menu @node Moving subtrees, Internal archiving, Archiving, Archiving @@ -6618,14 +6619,14 @@ @code{org-agenda-restore-windows-after-quit}. @menu -* Agenda files:: Files being searched for agenda information -* Agenda dispatcher:: Keyboard access to agenda views -* Built-in agenda views:: What is available out of the box? -* Presentation and sorting:: How agenda items are prepared for display -* Agenda commands:: Remote editing of Org trees -* Custom agenda views:: Defining special searches and views -* Exporting Agenda Views:: Writing a view to a file -* Agenda column view:: Using column view for collected entries +* Agenda files:: Files being searched for agenda information +* Agenda dispatcher:: Keyboard access to agenda views +* Built-in agenda views:: What is available out of the box? +* Presentation and sorting:: How agenda items are prepared for display +* Agenda commands:: Remote editing of Org trees +* Custom agenda views:: Defining special searches and views +* Exporting Agenda Views:: Writing a view to a file +* Agenda column view:: Using column view for collected entries @end menu @node Agenda files, Agenda dispatcher, Agenda Views, Agenda Views @@ -6767,12 +6768,12 @@ In this section we describe the built-in views. @menu -* Weekly/daily agenda:: The calendar page with current tasks -* Global TODO list:: All unfinished action items +* Weekly/daily agenda:: The calendar page with current tasks +* Global TODO list:: All unfinished action items * Matching tags and properties:: Structured information with fine-tuned search -* Timeline:: Time-sorted view for single file -* Search view:: Find entries by searching for text -* Stuck projects:: Find projects you need to review +* Timeline:: Time-sorted view for single file +* Search view:: Find entries by searching for text +* Stuck projects:: Find projects you need to review @end menu @node Weekly/daily agenda, Global TODO list, Built-in agenda views, Built-in agenda views @@ -7237,9 +7238,9 @@ associated with the item. @menu -* Categories:: Not all tasks are equal -* Time-of-day specifications:: How the agenda knows the time -* Sorting of agenda items:: The order of things +* Categories:: Not all tasks are equal +* Time-of-day specifications:: How the agenda knows the time +* Sorting of agenda items:: The order of things @end menu @node Categories, Time-of-day specifications, Presentation and sorting, Presentation and sorting @@ -7628,12 +7629,12 @@ @group (defun org-my-auto-exclude-function (tag) (and (cond - ((string= tag "Net") - (/= 0 (call-process "/sbin/ping" nil nil nil - "-c1" "-q" "-t1" "mail.gnu.org"))) - ((or (string= tag "Errand") (string= tag "Call")) - (let ((hour (nth 2 (decode-time)))) - (or (< hour 8) (> hour 21))))) + ((string= tag "Net") + (/= 0 (call-process "/sbin/ping" nil nil nil + "-c1" "-q" "-t1" "mail.gnu.org"))) + ((or (string= tag "Errand") (string= tag "Call")) + (let ((hour (nth 2 (decode-time)))) + (or (< hour 8) (> hour 21))))) (concat "-" tag))) (setq org-agenda-auto-exclude-function 'org-my-auto-exclude-function) @@ -7963,9 +7964,9 @@ dispatcher (@pxref{Agenda dispatcher}), just like the default commands. @menu -* Storing searches:: Type once, use often -* Block agenda:: All the stuff you need in a single buffer -* Setting Options:: Changing the rules +* Storing searches:: Type once, use often +* Block agenda:: All the stuff you need in a single buffer +* Setting Options:: Changing the rules @end menu @node Storing searches, Block agenda, Custom agenda views, Custom agenda views @@ -8350,29 +8351,29 @@ summarizes the markup rules used in an Org-mode buffer. @menu -* Structural markup elements:: The basic structure as seen by the exporter -* Images and tables:: Tables and Images will be included -* Literal examples:: Source code examples with special formatting -* Include files:: Include additional files into a document -* Index entries:: Making an index -* Macro replacement:: Use macros to create complex output -* Embedded LaTeX:: LaTeX can be freely used inside Org documents +* Structural markup elements:: The basic structure as seen by the exporter +* Images and tables:: Tables and Images will be included +* Literal examples:: Source code examples with special formatting +* Include files:: Include additional files into a document +* Index entries:: Making an index +* Macro replacement:: Use macros to create complex output +* Embedded LaTeX:: LaTeX can be freely used inside Org documents @end menu @node Structural markup elements, Images and tables, Markup, Markup @section Structural markup elements @menu -* Document title:: Where the title is taken from -* Headings and sections:: The document structure as seen by the exporter -* Table of contents:: The if and where of the table of contents -* Initial text:: Text before the first heading? -* Lists:: Lists -* Paragraphs:: Paragraphs -* Footnote markup:: Footnotes -* Emphasis and monospace:: Bold, italic, etc. -* Horizontal rules:: Make a line -* Comment lines:: What will *not* be exported +* Document title:: Where the title is taken from +* Headings and sections:: The document structure as seen by the exporter +* Table of contents:: The if and where of the table of contents +* Initial text:: Text before the first heading? +* Lists:: Lists +* Paragraphs:: Paragraphs +* Footnote markup:: Footnotes +* Emphasis and monospace:: Bold, italic, etc. +* Horizontal rules:: Make a line +* Comment lines:: What will *not* be exported @end menu @node Document title, Headings and sections, Structural markup elements, Structural markup elements @@ -8801,11 +8802,11 @@ to do with it. @menu -* Special symbols:: Greek letters and other symbols -* Subscripts and superscripts:: Simple syntax for raising/lowering text -* LaTeX fragments:: Complex formulas made easy -* Previewing LaTeX fragments:: What will this snippet look like? -* CDLaTeX mode:: Speed up entering of formulas +* Special symbols:: Greek letters and other symbols +* Subscripts and superscripts:: Simple syntax for raising/lowering text +* LaTeX fragments:: Complex formulas made easy +* Previewing LaTeX fragments:: What will this snippet look like? +* CDLaTeX mode:: Speed up entering of formulas @end menu @node Special symbols, Subscripts and superscripts, Embedded LaTeX, Embedded LaTeX @@ -9064,17 +9065,17 @@ enabled (default in Emacs 23). @menu -* Selective export:: Using tags to select and exclude trees -* Export options:: Per-file export settings -* The export dispatcher:: How to access exporter commands -* ASCII/Latin-1/UTF-8 export:: Exporting to flat files with encoding -* HTML export:: Exporting to HTML -* LaTeX and PDF export:: Exporting to La@TeX{}, and processing to PDF -* DocBook export:: Exporting to DocBook -* TaskJuggler export:: Exporting to TaskJuggler -* Freemind export:: Exporting to Freemind mind maps -* XOXO export:: Exporting to XOXO -* iCalendar export:: Exporting in iCalendar format +* Selective export:: Using tags to select and exclude trees +* Export options:: Per-file export settings +* The export dispatcher:: How to access exporter commands +* ASCII/Latin-1/UTF-8 export:: Exporting to flat files with encoding +* HTML export:: Exporting to HTML +* LaTeX and PDF export:: Exporting to La@TeX{}, and processing to PDF +* DocBook export:: Exporting to DocBook +* TaskJuggler export:: Exporting to TaskJuggler +* Freemind export:: Exporting to Freemind mind maps +* XOXO export:: Exporting to XOXO +* iCalendar export:: Exporting in iCalendar format @end menu @node Selective export, Export options, Exporting, Exporting @@ -9327,14 +9328,14 @@ language, but with additional support for tables. @menu -* HTML Export commands:: How to invoke HTML export -* Quoting HTML tags:: Using direct HTML in Org-mode -* Links in HTML export:: How links will be interpreted and formatted -* Tables in HTML export:: How to modify the formatting of tables -* Images in HTML export:: How to insert figures into HTML output -* Text areas in HTML export:: An alternative way to show an example -* CSS support:: Changing the appearance of the output -* JavaScript support:: Info and Folding in a web browser +* HTML Export commands:: How to invoke HTML export +* Quoting HTML tags:: Using direct HTML in Org-mode +* Links in HTML export:: How links will be interpreted and formatted +* Tables in HTML export:: How to modify the formatting of tables +* Images in HTML export:: How to insert figures into HTML output +* Text areas in HTML export:: An alternative way to show an example +* CSS support:: Changing the appearance of the output +* JavaScript support:: Info and Folding in a web browser @end menu @node HTML Export commands, Quoting HTML tags, HTML export, HTML export @@ -9681,12 +9682,12 @@ linked. @menu -* LaTeX/PDF export commands:: Which key invokes which commands -* Header and sectioning:: Setting up the export file structure -* Quoting LaTeX code:: Incorporating literal La@TeX{} code -* Tables in LaTeX export:: Options for exporting tables to La@TeX{} -* Images in LaTeX export:: How to insert figures into La@TeX{} output -* Beamer class export:: Turning the file into a presentation +* LaTeX/PDF export commands:: Which key invokes which commands +* Header and sectioning:: Setting up the export file structure +* Quoting LaTeX code:: Incorporating literal La@TeX{} code +* Tables in LaTeX export:: Options for exporting tables to La@TeX{} +* Images in LaTeX export:: How to insert figures into La@TeX{} output +* Beamer class export:: Turning the file into a presentation @end menu @node LaTeX/PDF export commands, Header and sectioning, LaTeX and PDF export, LaTeX and PDF export @@ -10011,12 +10012,12 @@ Currently DocBook exporter only supports DocBook V5.0. @menu -* DocBook export commands:: How to invoke DocBook export -* Quoting DocBook code:: Incorporating DocBook code in Org files -* Recursive sections:: Recursive sections in DocBook -* Tables in DocBook export:: Tables are exported as HTML tables -* Images in DocBook export:: How to insert figures into DocBook output -* Special characters:: How to handle special characters +* DocBook export commands:: How to invoke DocBook export +* Quoting DocBook code:: Incorporating DocBook code in Org files +* Recursive sections:: Recursive sections in DocBook +* Tables in DocBook export:: Tables are exported as HTML tables +* Images in DocBook export:: How to insert figures into DocBook output +* Special characters:: How to handle special characters @end menu @node DocBook export commands, Quoting DocBook code, DocBook export, DocBook export @@ -10442,10 +10443,10 @@ Publishing has been contributed to Org by David O'Toole. @menu -* Configuration:: Defining projects -* Uploading files:: How to get files up on the server -* Sample configuration:: Example projects -* Triggering publication:: Publication commands +* Configuration:: Defining projects +* Uploading files:: How to get files up on the server +* Sample configuration:: Example projects +* Triggering publication:: Publication commands @end menu @node Configuration, Uploading files, Publishing, Publishing @@ -10455,14 +10456,14 @@ and many other properties of a project. @menu -* Project alist:: The central configuration variable -* Sources and destinations:: From here to there -* Selecting files:: What files are part of the project? -* Publishing action:: Setting the function doing the publishing -* Publishing options:: Tweaking HTML export -* Publishing links:: Which links keep working after publishing? -* Sitemap:: Generating a list of all pages -* Generating an index:: An index that reaches across pages +* Project alist:: The central configuration variable +* Sources and destinations:: From here to there +* Selecting files:: What files are part of the project? +* Publishing action:: Setting the function doing the publishing +* Publishing options:: Tweaking HTML export +* Publishing links:: Which links keep working after publishing? +* Sitemap:: Generating a list of all pages +* Generating an index:: An index that reaches across pages @end menu @node Project alist, Sources and destinations, Configuration, Configuration @@ -10836,8 +10837,8 @@ more complex, with a multi-component project. @menu -* Simple example:: One-component publishing -* Complex example:: A multi-component publishing example +* Simple example:: One-component publishing +* Complex example:: A multi-component publishing example @end menu @node Simple example, Complex example, Sample configuration, Sample configuration @@ -10966,18 +10967,18 @@ The following sections describe Org-mode's code block handling facilities. @menu -* Structure of code blocks:: Code block syntax described -* Editing source code:: Language major-mode editing -* Exporting code blocks:: Export contents and/or results -* Extracting source code:: Create pure source code files -* Evaluating code blocks:: Place results of evaluation in the Org-mode buffer -* Library of Babel:: Use and contribute to a library of useful code blocks -* Languages:: List of supported code block languages -* Header arguments:: Configure code block functionality -* Results of evaluation:: How evaluation results are handled -* Noweb reference syntax:: Literate programming in Org-mode +* Structure of code blocks:: Code block syntax described +* Editing source code:: Language major-mode editing +* Exporting code blocks:: Export contents and/or results +* Extracting source code:: Create pure source code files +* Evaluating code blocks:: Place results of evaluation in the Org-mode buffer +* Library of Babel:: Use and contribute to a library of useful code blocks +* Languages:: List of supported code block languages +* Header arguments:: Configure code block functionality +* Results of evaluation:: How evaluation results are handled +* Noweb reference syntax:: Literate programming in Org-mode * Key bindings and useful functions:: Work quickly with code blocks -* Batch execution:: Call functions from the command line +* Batch execution:: Call functions from the command line @end menu @comment node-name, next, previous, up @@ -11271,8 +11272,8 @@ describes each header argument in detail. @menu -* Using header arguments:: Different ways to set header arguments -* Specific header arguments:: List of header arguments +* Using header arguments:: Different ways to set header arguments +* Specific header arguments:: List of header arguments @end menu @node Using header arguments, Specific header arguments, Header arguments, Header arguments @@ -11282,7 +11283,7 @@ specific (and having higher priority) than the last. @menu * System-wide header arguments:: Set global default values -* Language-specific header arguments:: Set default values by language +* Language-specific header arguments:: Set default values by language * Buffer-wide header arguments:: Set default values for a specific buffer * Header arguments in Org-mode properties:: Set default values for a buffer or heading * Code block specific header arguments:: The most common way to set values @@ -11419,25 +11420,25 @@ The following header arguments are defined: @menu -* var:: Pass arguments to code blocks -* results:: Specify the type of results and how they will +* var:: Pass arguments to code blocks +* results:: Specify the type of results and how they will be collected and handled -* file:: Specify a path for file output -* dir:: Specify the default (possibly remote) +* file:: Specify a path for file output +* dir:: Specify the default (possibly remote) directory for code block execution -* exports:: Export code and/or results -* tangle:: Toggle tangling and specify file name -* no-expand:: Turn off variable assignment and noweb +* exports:: Export code and/or results +* tangle:: Toggle tangling and specify file name +* no-expand:: Turn off variable assignment and noweb expansion during tangling * comments:: Toggle insertion of comments in tangled code files -* session:: Preserve the state of code evaluation -* noweb:: Toggle expansion of noweb references -* cache:: Avoid re-evaluating unchanged code blocks -* hlines:: Handle horizontal lines in tables -* colnames:: Handle column names in tables -* rownames:: Handle row names in tables -* shebang:: Make tangled files executable +* session:: Preserve the state of code evaluation +* noweb:: Toggle expansion of noweb references +* cache:: Avoid re-evaluating unchanged code blocks +* hlines:: Handle horizontal lines in tables +* colnames:: Handle column names in tables +* rownames:: Handle row names in tables +* shebang:: Make tangled files executable * eval:: Limit evaluation of specific code blocks @end menu @@ -12292,15 +12293,15 @@ @chapter Miscellaneous @menu -* Completion:: M-TAB knows what you need -* Speed keys:: Electric commands at the beginning of a headline -* Code evaluation security:: Org mode files evaluate inline code -* Customization:: Adapting Org to your taste -* In-buffer settings:: Overview of the #+KEYWORDS -* The very busy C-c C-c key:: When in doubt, press C-c C-c -* Clean view:: Getting rid of leading stars in the outline -* TTY keys:: Using Org on a tty -* Interaction:: Other Emacs packages +* Completion:: M-TAB knows what you need +* Speed keys:: Electric commands at the beginning of a headline +* Code evaluation security:: Org mode files evaluate inline code +* Customization:: Adapting Org to your taste +* In-buffer settings:: Overview of the #+KEYWORDS +* The very busy C-c C-c key:: When in doubt, press C-c C-c +* Clean view:: Getting rid of leading stars in the outline +* TTY keys:: Using Org on a tty +* Interaction:: Other Emacs packages @end menu @@ -12928,8 +12929,8 @@ with other code out there. @menu -* Cooperation:: Packages Org cooperates with -* Conflicts:: Packages that lead to conflicts +* Cooperation:: Packages Org cooperates with +* Conflicts:: Packages that lead to conflicts @end menu @node Cooperation, Conflicts, Interaction, Interaction @@ -13077,9 +13078,9 @@ @lisp (add-hook 'org-mode-hook - (lambda () - (org-set-local 'yas/trigger-key [tab]) - (define-key yas/keymap [tab] 'yas/next-field-group))) + (lambda () + (org-set-local 'yas/trigger-key [tab]) + (define-key yas/keymap [tab] 'yas/next-field-group))) @end lisp @item @file{windmove.el} by Hovav Shacham @@ -13121,16 +13122,16 @@ Org. @menu -* Hooks:: Who to reach into Org's internals -* Add-on packages:: Available extensions -* Adding hyperlink types:: New custom link types -* Context-sensitive commands:: How to add functionality to such commands -* Tables in arbitrary syntax:: Orgtbl for La@TeX{} and other programs -* Dynamic blocks:: Automatically filled blocks -* Special agenda views:: Customized views +* Hooks:: Who to reach into Org's internals +* Add-on packages:: Available extensions +* Adding hyperlink types:: New custom link types +* Context-sensitive commands:: How to add functionality to such commands +* Tables in arbitrary syntax:: Orgtbl for La@TeX{} and other programs +* Dynamic blocks:: Automatically filled blocks +* Special agenda views:: Customized views * Extracting agenda information:: Postprocessing of agenda information -* Using the property API:: Writing programs that use entry properties -* Using the mapping API:: Mapping over all or selected entries +* Using the property API:: Writing programs that use entry properties +* Using the mapping API:: Mapping over all or selected entries @end menu @node Hooks, Add-on packages, Hacking, Hacking @@ -13322,10 +13323,10 @@ @menu -* Radio tables:: Sending and receiving radio tables -* A LaTeX example:: Step by step, almost a tutorial -* Translator functions:: Copy and modify -* Radio lists:: Doing the same for lists +* Radio tables:: Sending and receiving radio tables +* A LaTeX example:: Step by step, almost a tutorial +* Translator functions:: Copy and modify +* Radio lists:: Doing the same for lists @end menu @node Radio tables, A LaTeX example, Tables in arbitrary syntax, Tables in arbitrary syntax @@ -14098,9 +14099,9 @@ (@pxref{Setting tags}) only for those set in these variables. @menu -* Setting up the staging area:: Where to interact with the mobile device -* Pushing to MobileOrg:: Uploading Org files and agendas -* Pulling from MobileOrg:: Integrating captured and flagged items +* Setting up the staging area:: Where to interact with the mobile device +* Pushing to MobileOrg:: Uploading Org files and agendas +* Pulling from MobileOrg:: Integrating captured and flagged items @end menu @node Setting up the staging area, Pushing to MobileOrg, MobileOrg, MobileOrg
--- a/doc/misc/trampver.texi Wed Sep 08 12:55:57 2010 +0900 +++ b/doc/misc/trampver.texi Wed Sep 22 15:46:51 2010 +0900 @@ -9,7 +9,7 @@ @c In the Tramp CVS, the version number is auto-frobbed from @c configure.ac, so you should edit that file and run @c "autoconf && ./configure" to change the version number. -@set trampver 2.1.19 +@set trampver 2.2.0-pre @c Other flags from configuration @set instprefix /usr/local @@ -56,7 +56,6 @@ @set emacsothername XEmacs @set emacsotherdir xemacs @set emacsotherfilename tramp-xemacs.html -@set japanesemanual tramp_ja-emacs.html @end ifset @c XEmacs counterparts. @@ -73,7 +72,6 @@ @set emacsothername GNU Emacs @set emacsotherdir emacs @set emacsotherfilename tramp-emacs.html -@set japanesemanual tramp_ja-xemacs.html @end ifset @ignore
--- a/etc/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/etc/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,16 @@ +2010-09-13 Michael Albinus <michael.albinus@gmx.de> + + * NEWS: Some Tramp methods are discontinued. + +2010-09-11 Glenn Morris <rgm@gnu.org> + + * emacs.bash, emacs.csh, ms-kermit: Remove obsolete files (use + emacsclient -a instead of the first two). + +2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * NEWS: Mention the new libxml2 functions. + 2010-08-25 Kenichi Handa <handa@m17n.org> * HELLO: Change designation sequences for Arabic text.
--- a/etc/NEWS Wed Sep 08 12:55:57 2010 +0900 +++ b/etc/NEWS Wed Sep 22 15:46:51 2010 +0900 @@ -49,7 +49,7 @@ ** There is a new configure option --enable-use-lisp-union-type. This is only useful for Emacs developers to debug certain types of bugs. -These is not a new feature; only the configure flag is new. +This is not a new feature; only the configure flag is new. --- ** New translation of the Emacs Tutorial in Hebrew is available @@ -113,21 +113,17 @@ top, left, right or bottom. The Options => Show/Hide menu has entries for this. -** ImageMagick support +** ImageMagick support. It is now possible to use the Imagemagick library to load many new -image formats in Emacs. - -To enable, use the following configure option: ---with-imagemagick +image formats in Emacs. To enable this, use the configure option +`--with-imagemagick'. -The new function (imagemagick-types) returns a list of image file -extensions that your installation of imagemagick supports. +The new function `imagemagick-types' returns a list of image file +extensions that your installation of ImageMagick supports. The +function `imagemagick-register-types' enables ImageMagick support for +these image types, minus those listed in `imagemagick-types-inhibit'. -The function (imagemagick-register-types) will enable the imagemagick -support for the extensions in imagemagick-types minus the types listed -in imagemagick-types-inhibit. - -See the Emacs Manual for more information. +See the Emacs Lisp Reference Manual for more information. ** The colors for selected text (the region face) are taken from the GTK theme when Emacs is built with GTK. @@ -161,7 +157,7 @@ scroll a line instead of full screen. ** New property `scroll-command' should be set on a command's symbol to -define it as a scroll command affected by `scroll-preserve-screen-position. +define it as a scroll command affected by `scroll-preserve-screen-position'. ** Trash changes @@ -193,8 +189,6 @@ ** completion-at-point is now an alias for complete-symbol. -** mouse-region-delete-keys has been deleted. - ** Deletion changes *** New option `delete-active-region'. @@ -240,6 +234,8 @@ * Changes in Specialized Modes and Packages in Emacs 24.1 +** latex-electric-env-pair-mode keeps \begin..\end matched on the fly. + ** FIXME: xdg-open for browse-url and reportbug, 2010/08. (Close bug#4546?) ** Archive Mode has basic support to browse 7z archives. @@ -261,6 +257,7 @@ (setq completion-pcm-complete-word-inserts-delimiters t) ** mpc.el: Can use pseudo tags of the form tag1|tag2 as a union of two tags. + ** Customize *** Customize buffers now contain a search field. @@ -321,9 +318,25 @@ variables `sql-product', `sql-user', `sql-server', `sql-database' and `sql-port' can now be safely used as local variables. -*** Added ability to login with a port on MySQL. +*** `sql-dialect' is a synonym for `sql-product'. + +*** Added ability to login with a port on MySQL and Postgres. The custom variable `sql-port' can be specified for connection to -MySQL servers. +MySQL or Postgres servers. By default, the port is not listed in +either login parameter, but will be added to the command line if set +to a non-zero value. + +*** Dynamic selection of product in an SQL interactive session. +If you use `sql-product-interactive' to start an SQL interactive +session it uses the current value of `sql-product'. Preceding the +invocation with C-u will force it to ask for the product before +creating the session. + +*** Renaming a SQL interactive buffer when it is created. +Prefixing the SQL interactive commands (`sql-sqlite', `sql-postgres', +`sql-mysql', etc.) with C-u will force a new interactive session to be +started and will prompt for the new name. This will reduce the need +for `sql-rename-buffer' is most common use cases. *** Command continuation prompts in SQL interactive mode are suppressed. Multiple line commands in SQL interactive mode, generate command @@ -338,22 +351,34 @@ which is a list of the parameters to be prompted for before a connection is established. -By default, the value of the parameter is simply prompted for. For -`server' and `database', they can be specified in a list as shown -below: +The lists consist of the following five tokens: `user', `password', +`database', `server', and `port'. The order in which they appear is +the order in which they are prompted. The tokens symbols can be +replaced by a sublist starting with the token and followed by a plist +which control the prompting for values. The tokens `user', +`database', and `server' each can take a property of :default which +specifies the value to be used if no value is entered. The +`database', `server', and `port' tokens handle the :completion +property which restricts the entry to either one of the values in the +list or to one of the values returned by the function provided as the +property value. The `database' and `server' tokens also accept the +:file property whose value is a regexp to identify useful file names. - (server :file ARG) - (database :file ARG) - (server :completion ARG) - (database :completion ARG) + (user :default DEF) + (database :default DEF + :file FILEPAT + :completion COMPLETE) + (server :default DEF + :file FILEPAT + :completion COMPLETE) -The ARG when :file is specified is a regexp that will match valid file -names (without the directory portion). Generally these strings will -be of the form ".+\.SUF" where SUF is the desired file suffix. +The FILEPAT when :file is specified is a regexp that will match valid +file names (without the directory portion). Generally these strings +will be of the form ".+\.SUF" where SUF is the desired file suffix. -When :completion is specified, the ARG corresponds to the PREDICATE -argument to the `completing-read' function (a list of possible values -or a function returning such a list). +When :completion is specified, the COMPLETE corresponds to the +PREDICATE argument to the `completing-read' function (a list of +possible values or a function returning such a list). *** Added `sql-connection-alist' to record login parameter values. An alist for recording different username, database and server @@ -383,7 +408,7 @@ for the users password and then connect to the Oracle database. **** Added SQL->Start... submenu when connections are defined. -When connections have been defined, There is a submenu available that +When connections have been defined, there is a submenu available that allows the user to select one to start a SQLi session. The "Start SQLi Session" item moves to the "Start..." submenu when cnnections have been defined. @@ -393,6 +418,26 @@ `sql-save-connection' will gather the login params specified for the session and save them as a new connection. +*** List database objects and details. +Once a SQL interactive session has been started, you can get a list of +the objects in the database and see details of those objects. The +objects shown and the details available are product specific. + +**** List all objects. +Using `M-x sql-list-all', `C-c C-l a' or selecting "SQL->List all +objects" will list all the objects in the database. At a minimum it +lists the tables and views in the database. Preceeding the command by +universal argument may provide additional details or extend the +listing to include other schemas objects. The list will appear in a +separate window in view-mode. + +**** List Table details. +Using `M-x sql-list-table', `C-c C-l t' or selecting "SQL->List Table +details" will ask for the name of a database table or view and display +the list of columns in the relation. Preceeding the comand with the +universal argument may provide additional details about each column. +The list will appear in a separate window in view-mode. + *** Added option `sql-send-terminator'. When set makes sure that each command sent with `sql-send-*' commands are properly terminated and submitted to the SQL processor. @@ -424,6 +469,11 @@ *** It is possible now, to access alternative buses than the default system or session bus. +** Tramp + +*** The following access methods are discontinued: "ssh1_old", +"ssh2_old", "scp1_old", "scp2_old" and "fish". + * New Modes and Packages in Emacs 24.1 @@ -470,14 +520,25 @@ * Lisp changes in Emacs 24.1 +** New variable syntax-propertize-function to set syntax-table properties. +Replaces font-lock-syntactic-keywords which are now obsolete. +This allows syntax-table properties to be set independently from font-lock: +just call syntax-propertize to make sure the text is propertized. +Together with this new variable come a new hook +syntax-propertize-extend-region-functions, as well as two helper functions: +syntax-propertize-via-font-lock to reuse old font-lock-syntactic-keywords +as-is; and syntax-propertize-rules which provides a new way to specify +syntactic rules. + ** New hook post-self-insert-hook run at the end of self-insert-command. ++++ ** Syntax tables support a new "comment style c" additionally to style b. ** frame-local variables cannot be let-bound any more. ** prog-mode is a new major-mode meant to be the parent of programming mode. ** define-minor-mode accepts a new keyword :variable. -** `delete-file' and `delete-directory now accept optional arg TRASH. +** `delete-file' and `delete-directory' now accept optional arg TRASH. Trashing is performed if TRASH and `delete-by-moving-to-trash' are both non-nil. Interactively, TRASH defaults to t, unless a prefix argument is supplied (see Trash changes, above). @@ -497,6 +558,14 @@ *** `image-extension-data' is renamed to `image-metadata'. +** XML and HTML parsing + +*** If Emacs is compiled with libxml2 support (which is the default), +two new Emacs Lisp-level functions are defined: `html-parse-string' +(which will parse "real world" HTML) and `xml-parse-string' (which +parses XML). Both return an Emacs Lisp parse tree. See the Emacs +Lisp Reference Manual for details. + ** Isearch *** New hook `isearch-update-post-hook' that runs in `isearch-update'.
--- a/etc/NEWS.23 Wed Sep 08 12:55:57 2010 +0900 +++ b/etc/NEWS.23 Wed Sep 22 15:46:51 2010 +0900 @@ -40,6 +40,8 @@ * Lisp changes in Emacs 23.3 +** The use of unintern without an obarray arg is declared obsolete. + ** New function byte-to-string, like char-to-string but for bytes.
--- a/etc/TODO Wed Sep 08 12:55:57 2010 +0900 +++ b/etc/TODO Wed Sep 22 15:46:51 2010 +0900 @@ -625,6 +625,508 @@ the window associated with that modeline. http://lists.gnu.org/archive/html/emacs-devel/2007-09/msg02416.html +* Things to be done for specific packages or features + +** ImageMagick support + +*** image-type-header-regexps priorities the jpeg loader over the +ImageMagick one. This is not wrong, but how should a user go about +prefering the ImageMagick loader? The user might like zooming etc in jpegs. + +Try (setq image-type-header-regexps nil) for a quick hack to prefer +ImageMagick over the jpg loader. + +*** For some reason its unbearably slow to look at a page in a large +image bundle using the :index feature. The ImageMagick "display" +command is also a bit slow, but nowhere near as slow as the Emacs +code. It seems ImageMagick tries to unpack every page when loading the +bundle. This feature is not the primary usecase in Emacs though. + +ImageMagick 6.6.2-9 introduced a bugfix for single page djvu load. It +is now much faster to use the :index feature, but still not very fast. + +*** Try to cache the num pages calculation. It can take a while to +calculate the number of pages, and if you need to do it for each page +view, page-flipping becomes uselessly slow. + +*** Integrate with image-dired. + +*** Integrate with docview. + +*** Integrate with image-mode. +Some work has been done, e.g. M-x image-transform-fit-to-height will +fit the image to the height of the Emacs window. + +*** Look for optimizations for handling images with low depth. +Currently the code seems to default to 24 bit RGB which is costly for +images with lower bit depth. + +*** Decide what to do with some uncommitted imagemagick support +functions for image size etc. + +*** Test with more systems. +Tested on Fedora 12, 14, and the libmagick that ships with it. +I also tried using an ImageMagick compiled from their SVN, in +parallel with the one packaged by Fedora, it worked well. +Ubuntu 8.04 was tested, but it seems it ships a broken ImageMagick. + +** nxml mode + +*** High priority + +**** Command to insert an element template, including all required +attributes and child elements. When there's a choice of elements +possible, we could insert a comment, and put an overlay on that +comment that makes it behave like a button with a pop-up menu to +select the appropriate choice. + +**** Command to tag a region. With a schema should complete using legal +tags, but should work without a schema as well. + +**** Provide a way to conveniently rename an element. With a schema should +complete using legal tags, but should work without a schema as well. + +*** Outlining + +**** Implement C-c C-o C-q. + +**** Install pre/post command hook for moving out of invisible section. + +**** Put a modify hook on invisible sections that expands them. + +**** Integrate dumb folding somehow. + +**** An element should be able to be its own heading. + +**** Optimize to avoid complete buffer scan on each command. + +**** Make it work with HTML-style headings (i.e. level indicated by +name of heading element rather than depth of section nesting). + +**** Recognize root element as a section provided it has a title, even +if it doesn't match section-element-name-regex. + +**** Support for incremental search automatically making hidden text visible. + +**** Allow title to be an attribute. + +**** Command that says to recognize the tag at point as a section/heading. + +**** Explore better ways to determine when an element is a section +or a heading. + +**** rng-next-error needs to either ignore invisible portion or reveal it +(maybe use isearch oriented text properties). + +**** Errors within hidden section should be highlighted by underlining the +ellipsis. + +**** Make indirect buffers work. + +**** How should nxml-refresh outline recover from non well-formed tags? + +**** Hide tags in title elements? + +**** Use overlays instead of text properties for holding outline state? +Necessary for indirect buffers to work? + +**** Allow an outline to go in the speedbar. + +**** Split up outlining manual section into subsections. + +**** More detail in the manual about each outlining command. + +**** More menu entries for hiding/showing? + +**** Indication of many lines have been hidden? + +*** Locating schemas + +**** Should rng-validate-mode give the user an opportunity to specify a +schema if there is currently none? Or should it at least give a hint +to the user how to specify a non-vacuous schema? + +**** Support for adding new schemas to schema-locating files. +Add documentElement and namespace elements. + +**** C-c C-w should be able to report current type id. + +**** Implement doctypePublicId. + +**** Implement typeIdBase. + +**** Implement typeIdProcessingInstruction. + +**** Support xml:base. + +**** Implement group. + +**** Find preferred prefix from schema-locating files. Get rid of +rng-preferred-prefix-alist. + +**** Inserting document element with vacuous schema should complete using +document elements declared in schema locating files, and set schema +appropriately. + +**** Add a ruleType attribute to the <include> element? + +**** Allow processing instruction in prolog to contain the compact syntax +schema directly. + +**** Use RDDL to locate a schema based on the namespace URI. + +**** Should not prompt to add redundant association to schema locating file. + +**** Command to reload current schema. + +*** Schema-sensitive features + +**** Should filter dynamic markup possibilities using schema validity, by +adding hook to nxml-mode. + +**** Dynamic markup word should (at least optionally) be able to look in +other buffers that are using nxml-mode. + +**** Should clicking on Invalid move to next error if already on an error? + +**** Take advantage of a:documentation. Needs change to schema format. + +**** Provide feasible validation (as in Jing) toggle. + +**** Save the validation state as a property on the error overlay to enable +more detailed diagnosis. + +**** Provide an Error Summary buffer showing all the validation errors. + +**** Pop-up menu. What is useful? Tag a region (should be greyed out if +the region is not balanced). Suggestions based on error messages. + +**** Have configurable list of namespace URIs so that we can provide +namespace URI completion on extension elements or with schema-less documents. + +**** Allow validation to handle XInclude. + +**** ID/IDREF support. + +*** Completion + +**** Make it work with icomplete. Only use a function to complete when +some of the possible names have undeclared namespaces. + +**** How should C-return in mixed text work? + +**** When there's a vacuous schema, C-return after < will insert the end-tag. +Is this a bug or a feature? + +**** After completing start-tag, ensure we don't get unhelpful message +from validation + +**** Syntax table for completion. + +**** Should complete start-tag name with a space if namespace attributes +are required. + +**** When completing start-tag name with no prefix and it doesn't match +should try to infer namespace from local name. + +**** Should completion pay attention to characters after point? If so, how? + +**** When completing start-tag name, add required atts if only one required +attribute. + +**** When completing attribute name, add attribute value if only one value +is possible. + +**** After attribute-value completion, insert space after close delimiter +if more attributes are required. + +**** Complete on enumerated data values in elements. + +**** When in context that allows only elements, should get tag +completion without having to type < first. + +**** When immediately after start-tag name, and name is valid and not +prefix of any other name, should C-return complete on attribute names? + +**** When completing attributes, more consistent to ignore all attributes +after point. + +**** Inserting attribute value completions needs to be sensitive to what +delimiter is used so that it quotes the correct character. + +**** Complete on encoding-names in XML decl. + +**** Complete namespace declarations by searching for all namespaces +mentioned in the schema. + +*** Well-formed XML support + +**** Deal better with Mule-UCS + +**** Deal with UTF-8 BOM when reading. + +**** Complete entity names. + +**** Provide some support for entity names for MathML. + +**** Command to repeat the last tag. + +**** Support for changing between character references and characters. +Need to check that context is one in which character references are +allowed. xmltok prolog parsing will need to distinguish parameter +literals from other kinds of literal. + +**** Provide a comment command to bind to M-; that works better than the +normal one. + +**** Make indenting in a multi-line comment work. + +**** Structure view. Separate buffer displaying element tree. +Be able to navigate from structure view to document and vice-versa. + +**** Flash matching >. + +**** Smart selection command that selects increasingly large syntactically +coherent chunks of XML. If point is in an attribute value, first +select complete value; then if command is repeated, select value plus +delimiters, then select attribute name as well, then complete +start-tag, then complete element, then enclosing element, etc. + +**** ispell integration. + +**** Block-level items in mixed content should be indented, e.g: + <para>This is list: + <ul> + <li>item</li> + +**** Provide option to indent like this: + <para>This is a paragraph + occupying multiple lines.</para> + +**** Option to add make a / that closes a start-tag electrically insert a +space for the XHTML guys. + +**** C-M-q should work. + +*** Datatypes + +**** Figure out workaround for CJK characters with regexps. + +**** Does category C contain Cn? + +**** Do ENTITY datatype properly. + +*** XML Parsing Library + +**** Parameter entity parsing option, nil (never), t (always), +unless-standalone (unless standalone="yes" in XML declaration). + +**** When a file is currently being edited, there should be an option to +use its buffer instead of the on-disk copy. + +*** Handling all XML features + +**** Provide better support for editing external general parsed entities. +Perhaps provide a way to force ignoring undefined entities; maybe turn +this on automatically with <?xml encoding=""?> (with no version +pseudo-att). + +**** Handle internal general entity declarations containing elements. + +**** Handle external general entity declarations. + +**** Handle default attribute declarations in internal subset. + +**** Handle parameter entities (including DTD). + +*** RELAX NG + +**** Do complete schema checking, at least optionally. + +**** Detect include/external loops during schema parse. + +**** Coding system detection for schemas. Should use utf-8/utf-16 per the +spec. But also need to allow encodings other than UTF-8/16 to support +CJK charsets that Emacs cannot represent in Unicode. + +*** Catching XML errors + +**** Check public identifiers. + +**** Check default attribute values. + +*** Performance + +**** Explore whether overlay-recenter can cure overlays performance problems. + +**** Cache schemas. Need to have list of files and mtimes. + +**** Make it possible to reduce rng-validate-chunk-size significantly, +perhaps to 500 bytes, without bad performance impact: don't do +redisplay on every chunk; pass continue functions on other uses of +rng-do-some-validation. + +**** Cache after first tag. + +**** Introduce a new name class that is a choice between names (so that +we can use member) + +**** intern-choice should simplify after patterns with same 1st/2nd args + +**** Large numbers of overlays slow things down dramatically. Represent +errors using text properties. This implies we cannot incrementally +keep track of the number of errors, in order to determine validity. +Instead, when validation completes, scan for any characters with an +error text property; this seems to be fast enough even with large +buffers. Problem with error at end of buffer, where there's no +character; need special variable for this. Need to merge face from +font-lock with the error face: use :inherit attribute with list of two +faces. How do we avoid making rng-valid depend on nxml-mode? + +*** Error recovery + +**** Don't stop at newline in looking for close of start-tag. + +**** Use indentation to guide recovery from mismatched end-tags + +**** Don't keep parsing when currently not well-formed but previously +well-formed + +**** Try to recover from a bad start-tag by popping an open element if +there was a mismatched end-tag unaccounted for. + +**** Try to recover from a bad start-tag open on the hypothesis that there +was an error in the namespace URI. + +**** Better recovery from ill-formed XML declarations. + +*** Useability improvements + +**** Should print a "Parsing..." message during long movements. + +**** Provide better position for reference to undefined pattern error. + +**** Put Well-formed in the mode-line when validating against any-content. + +**** Trim marking of illegal data for leading and trailing whitespace. + +**** Show Invalid status as soon as we are sure it's invalid, rather than +waiting for everything to be completely up to date. + +**** When narrowed, Valid or Invalid status should probably consider only +validity of narrowed region. + +*** Bug fixes + +**** Need to give an error for a document like: <foo/><![CDATA[ ]]> + +**** Make nxml-forward-balanced-item work better for the prolog. + +**** Make filling and indenting comments work in the prolog. + +**** Should delete RNC Input buffers. + +**** Figure out what regex use for NCName and use it consistently, + +**** Should have not-well-formed tokens in ref. + +**** Require version in XML declaration? Probably not because prevents +use for external parsed entities. At least forbid standalone without version. + +**** Reject schema that compiles to rng-not-allowed-ipattern. + +**** Move point backwards on schema parse error so that it's on the right token. + +*** Internal + +**** Use rng-quote-string consistently. + +**** Use parsing library for XML to texinfo conversion. + +**** Rename xmltok.el to nxml-token.el. Use nxml-t- prefix instead of +xmltok-. Change nxml-t-type to nxml-t-token-type, nxml-t-start to +nxml-t-token-start. + +**** Can we set fill-prefix to nil and rely on indenting? + +**** xmltok should make available replacement text of entities containing +elements + +**** In rng-valid, instead of using modification-hooks and +insert-behind-hooks on dependent overlays, use same technique as nxml-mode. + +**** Port to XEmacs. Issues include: Unicode (XEmacs seems to be based on +Mule-UCS); overlays/text properties vs extents; absence of +fontification-functions hook. + +*** Fontification + +**** Allow face to depend on element qname, attribute qname, attribute +value. Use list with pairs of (R . F), where R specifies regexps and +F specifies faces. How can this list be made to depend on the document type? + +*** Other + +**** Support RELAX NG XML syntax (use XML parsing library). + +**** Support W3C XML Schema (use XML parsing library). + +**** Command to infer schema from current document (like trang). + +*** Schemas + +**** XSLT schema should take advantage of RELAX NG to express cooccurrence +constraints on attributes (e.g. xsl:template). + +*** Documentation + +**** Move material from README to manual. + +**** Document encodings. + +*** Notes + +**** How can we allow an error to be displayed on a different token from +where it is detected? In particular, for a missing closing ">" we +will need to display it at the beginning of the following token. At the +moment, when we parse the following token the error overlay will get cleared. + +**** How should rng-goto-next-error deal with narrowing? + +**** Perhaps should merge errors having same start position even if they +have different ends. + +**** How to handle surrogates? One possibility is to be compatible with +utf8.e: represent as sequence of 4 chars. But utf-16 is incompatible +with this. + +**** Should we distinguish well-formedness errors from invalidity errors? +(I think not: we may want to recover from a bad start-tag by implying +an end-tag.) + +**** Seems to be a bug with Emacs, where a mouse movement that causes +help-echo text to appear counts as pending input but does not cause +idle timer to be restarted. + +**** Use XML to represent this file. + +**** I had a TODO which said simply "split-string". What did I mean? + +**** Investigate performance on large files all on one line. + +*** Issues for Emacs versions >= 22 + +**** Take advantage of UTF-8 CJK support. + +**** Supply a next-error-function. + +**** Investigate this NEWS item "Emacs now tries to set up buffer coding +systems for HTML/XML files automatically." + +**** Take advantage of the pointer text property. + +**** Leverage char-displayable-p. + * Internal changes ** Cleanup all the GC_ mark bit stuff -- there is no longer any distinction
--- a/etc/emacs.bash Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -### emacs.bash --- contact/resume an existing Emacs, or start a new one - -## Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -## Free Software Foundation, Inc. - -## Author: Noah Friedman - -## This file is part of GNU Emacs. - -## GNU Emacs is free software: you can redistribute it and/or modify -## it under the terms of the GNU General Public License as published by -## the Free Software Foundation, either version 3 of the License, or -## (at your option) any later version. - -## GNU Emacs is distributed in the hope that it will be useful, -## but WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU General Public License for more details. - -## You should have received a copy of the GNU General Public License -## along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -### Commentary: - -## This file is obsolete. Use emacsclient -a instead. - -## This defines a bash command named `edit' which contacts/resumes an -## existing emacs or starts a new one if none exists. - -## One way or another, any arguments are passed to emacs to specify files -## (provided you have loaded `resume.el'). - -## This function assumes the emacs program is named `emacs' and is somewhere -## in your load path. If either of these is not true, the most portable -## (and convenient) thing to do is to make an alias called emacs which -## refers to the real program, e.g. -## -## alias emacs=/usr/local/bin/gemacs - -function edit () -{ - local windowsys="${WINDOW_PARENT+sun}" - - windowsys="${windowsys:-${DISPLAY+x}}" - - if [ -n "${windowsys:+set}" ]; then - # Do not just test if these files are sockets. On some systems - # ordinary files or fifos are used instead. Just see if they exist. - if [ -e "${HOME}/.emacs_server" -o -e "/tmp/emacs${UID}/server" ]; then - emacsclient "$@" - return $? - else - echo "edit: starting emacs in background..." 1>&2 - fi - - case "${windowsys}" in - x ) (emacs "$@" &) ;; - sun ) echo "unsupported window system"; return 1 ;; - esac - else - if jobs %emacs 2> /dev/null ; then - echo "$(pwd)" "$@" >| ${HOME}/.emacs_args && fg %emacs - else - emacs "$@" - fi - fi -} - - -# arch-tag: 1e1b74b9-bf2c-4b23-870f-9eebff7515cb -### emacs.bash ends here
--- a/etc/emacs.csh Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -### emacs.csh - -## Add legal notice if non-trivial amounts of code are added. - -## Author: Michael DeCorte - -### Commentary: - -## This file is obsolete. Use emacsclient -a instead. - -## This defines a csh command named `edit' which resumes an -## existing Emacs or starts a new one if none exists. -## One way or another, any arguments are passed to Emacs to specify files -## (provided you have loaded `resume.el'). - -## These are the possible values of $whichjob -## 1 = new ordinary emacs (the -nw is so that it doesn't try to do X) -## 2 = resume emacs -## 3 = new emacs under X (-i is so that you get a reasonable icon) -## 4 = resume emacs under X -set EMACS_PATTERN="^\[[0-9]\] . Stopped ............ $EMACS" - -alias edit 'set emacs_command=("emacs -nw \!*" "fg %emacs" "emacs -i \!* &"\ - "emacsclient \!* &") ; \ - jobs >! $HOME/.jobs; grep "$EMACS_PATTERN" < $HOME/.jobs >& /dev/null; \ - @ isjob = ! $status; \ - @ whichjob = 1 + $isjob + $?DISPLAY * 2 + $?WINDOW_PARENT * 4; \ - test -S ~/.emacs_server && emacsclient \!* \ - || echo `pwd` \!* >! ~/.emacs_args && eval $emacs_command[$whichjob]' - -# arch-tag: 433d58df-15b9-446f-ad37-f0393e3a23d4
--- a/etc/ms-kermit Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,172 +0,0 @@ -;;; The code here is forced by the interface, and is not subject to -;;; copyright, constituting the only possible expression of the algorithm -;;; in this format. - -;;; This file is designed for an 8-bit connection. -;;; Use the file ms-7bkermit if you have a 7-bit connection. - -;; Meta key mappings for EMACS -;; By Robert Earl (rearl@watnxt3.ucr.edu) -;; May 13, 1990 -;; -;; WARNING: -;; requires an 8-bit path to host. many dialups and lans won't pass the -;; eighth bit by default and may require a special command to turn this -;; off. `screen' is known to mask the eighth bit of input as well. - -set term controls 8-bit -set translation key off - -;; control keys -set key \3449 \128 ;; m-c-@ -set key \3358 \129 ;; m-c-a -set key \3376 \130 ;; m-c-b -set key \3374 \131 ;; m-c-c -set key \3360 \132 ;; m-c-d -set key \3346 \133 ;; m-c-e -set key \3361 \134 ;; m-c-f -set key \3362 \135 ;; m-c-g -set key \3342 \136 ;; m-bs -set key \3363 \136 ;; m-c-h (sends same code as above) -set key \2469 \137 ;; m-tab -set key \3351 \137 ;; m-c-i (same as above) -set key \3364 \138 ;; m-c-j -set key \3365 \139 ;; m-c-k -set key \3366 \140 ;; m-c-l -;set key \3378 \141 ;; m-c-m -set key \2332 \141 ;; m-ret (sends same code as above) -set key \3377 \142 ;; m-c-n -set key \3352 \143 ;; m-c-o -set key \3353 \144 ;; m-c-p -set key \3344 \145 ;; m-c-q -set key \3347 \146 ;; m-c-r -set key \3359 \147 ;; m-c-s -set key \3348 \148 ;; m-c-t -set key \3350 \149 ;; m-c-u -set key \3375 \150 ;; m-c-v -set key \3345 \151 ;; m-c-w -set key \3373 \152 ;; m-c-x -set key \3349 \153 ;; m-c-y -set key \3372 \154 ;; m-c-z - -;; misc keys -;set key \3354 \155 ;; m-c-[ -set key \2305 \155 ;; m-esc (sends same as above) -set key \3371 \156 ;; m-c-\ -set key \3355 \157 ;; m-c-] -set key \3453 \158 ;; m-c-^ -set key \3458 \159 ;; m-c-_ - -;; \160 is conspicuously missing here-- -;; alt-spc doesn't generate a distinct scan code... -;; neither do shift-spc and ctrl-spc. -;; no idea why. - -set key \2936 \161 ;; m-! -set key \2856 \162 ;; m-" -set key \2938 \163 ;; m-# -set key \2939 \164 ;; m-$ -set key \2940 \165 ;; m-% -set key \2942 \166 ;; m-& -set key \2344 \167 ;; m-' -set key \2944 \168 ;; m-( -set key \2945 \169 ;; m-) -set key \2943 \170 ;; m-* -set key \2947 \171 ;; m-+ -set key \2355 \172 ;; m-, -set key \2434 \173 ;; m-- -set key \2356 \174 ;; m-. -set key \2357 \175 ;; m-/ - -;; number keys -set key \2433 \176 ;; m-0 -set key \2424 \177 ;; m-1 -set key \2425 \178 -set key \2426 \179 -set key \2427 \180 -set key \2428 \181 -set key \2429 \182 -set key \2430 \183 -set key \2431 \184 -set key \2432 \185 ;; m-9 - -set key \2855 \186 ;; m-: -set key \2343 \187 ;; m-; -set key \2867 \188 ;; m-< -set key \2435 \189 ;; m-= -set key \2868 \190 ;; m-> -set key \2869 \191 ;; m-? -set key \2937 \192 ;; m-@ - -;; shifted A-Z -set key \2846 \193 ;; m-A -set key \2864 \194 -set key \2862 \195 -set key \2848 \196 -set key \2834 \197 -set key \2849 \198 -set key \2850 \199 -set key \2851 \200 -set key \2839 \201 -set key \2852 \202 -set key \2853 \203 -set key \2854 \204 -set key \2866 \205 -set key \2865 \206 -set key \2840 \207 -set key \2841 \208 -set key \2832 \209 -set key \2835 \210 -set key \2847 \211 -set key \2836 \212 -set key \2838 \213 -set key \2863 \214 -set key \2833 \215 -set key \2861 \216 -set key \2837 \217 -set key \2860 \218 ;; m-Z - -set key \2330 \219 ;; m-[ -set key \2347 \220 ;; m-\ -set key \2331 \221 ;; m-] -set key \2941 \222 ;; m-^ -set key \2946 \223 ;; m-_ -set key \2345 \224 ;; m-` - -;; lowercase a-z -set key \2334 \225 ;; m-a -set key \2352 \226 -set key \2350 \227 -set key \2336 \228 -set key \2322 \229 -set key \2337 \230 -set key \2338 \231 -set key \2339 \232 -set key \2327 \233 -set key \2340 \234 -set key \2341 \235 -set key \2342 \236 -set key \2354 \237 -set key \2353 \238 -set key \2328 \239 -set key \2329 \240 -set key \2320 \241 -set key \2323 \242 -set key \2335 \243 -set key \2324 \244 -set key \2326 \245 -set key \2351 \246 -set key \2321 \247 -set key \2349 \248 -set key \2325 \249 -set key \2348 \250 ;; m-z - -;; more shifted misc. keys -set key \2842 \251 ;; m-{ -set key \2859 \252 ;; m-| -set key \2843 \253 ;; m-} -set key \2857 \254 ;; m-~ -set key \2318 \255 ;; m-del - - -;;; arch-tag: 93cefb0a-2b07-4d09-ae78-4d807b15645d
--- a/lisp/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,868 @@ +2010-09-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/smie.el (smie-debug--describe-cycle): Fix typo. + (smie-indent-comment): Be more careful with comment-start-skip. + (smie-indent-comment-close, smie-indent-comment-inside): New funs. + (smie-indent-functions): Use them. + +2010-09-21 Michael Albinus <michael.albinus@gmx.de> + + * net/ange-ftp.el (ange-ftp-skip-msgs): Add "^504 ..." message. + +2010-09-21 Jan Djärv <jan.h.d@swipnet.se> + + * menu-bar.el (menu-bar-set-tool-bar-position): customize-set-variable + tool-bar-position. Don't modify frame parameters here. + (menu-bar-options-save): Add tool-bar-position. + + * tool-bar.el (tool-bar-position): New defcustom (Bug#7049). + +2010-09-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * textmodes/reftex-parse.el (reftex-what-macro) + (reftex-context-substring): Let-bind forward-sexp-function to nil + since we don't need/want to treat \begin...\end as a block (bug#7053). + + * emacs-lisp/lisp.el (up-list): Don't do nothing silently. + + * simple.el (blink-matching-open): Use syntax-class. + + * progmodes/pascal.el (pascal-mode): Use define-derived-mode. + Set invisibility spec for pascal's outline mode. + (pascal-outline-change): Clean up calling convention. + (pascal-show-all, pascal-hide-other-defuns): Update callers. + + * progmodes/prolog.el (prolog-smie-forward-token) + (prolog-smie-backward-token): New functions. + (prolog-mode-variables): Use them to parse "!," correctly. + Set up smie-blink-matching for ".". + + * textmodes/ispell.el (ispell-start, ispell-end): Rename from `start' + and `end'. + (ispell-region, ispell-process-line): Update users. + + * textmodes/reftex-parse.el (reftex-what-macro): Don't hardcode + point-min==1. + + * textmodes/ispell.el: Fix commenting convention. + (ispell-parse-output): Simplify, use push. + (ispell-region): Use match-string-no-properties. + (ispell-begin-skip-region-regexp): Use mapconcat to simplify. + (ispell-minor-mode): Use define-minor-mode. + (ispell-message): Remove unused var `skip-regexp'. + (ispell-add-per-file-word-list): Use dynamic let-binding. + Try and use the proper comment marker. + + * mail/sendmail.el: Fix commenting convention. + (sendmail-send-it): Use line-beginning-position. + + * help-fns.el (describe-variable): Add original value, if applicable. + +2010-09-20 Juanma Barranquero <lekktu@gmail.com> + + * subr.el (y-or-n-p): Remove leftover code from revno 101459. + + * emacs-lisp/smie.el (smie-indent--hanging-p): Use `smie-indent--bolp'. + +2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/smie.el (smie-bnf-precedence-table): Improve error message. + (smie-debug--prec2-cycle, smie-debug--describe-cycle): New functions. + (smie-prec2-levels): Use them to better diagnose precedence cycles. + (smie-blink-matching-check): Don't signal a mismatch if car is t. + (smie-blink-matching-open): Rewrite to remove assumptions, so that + something like "." can also be a closer. + (smie--associative-p, smie-indent--hanging-p, smie-indent--bolp) + (smie-indent--offset, smie-indent--offset-rule, smie-indent--column): + Rename internal functions to use "--". Update callers. + + * frame.el (make-frame-names-alist): Don't list frames on other displays. + + * fringe.el (fringe-styles): New var. + (fringe-mode, fringe-query-style): Use it. + +2010-09-18 Michael R. Mauger <mmaug@yahoo.com> + + * progmodes/sql.el: Version 2.8 + (sql-login-params): Update widget structure; changes still needed. + (sql-product-alist): Add :list-all and :list-table features for + SQLite, Postgres and MySQL products. + (sql-redirect): Handle default value. + (sql-execute, sql-execute-feature): New functions. + (sql-read-table-name): New function. + (sql-list-all, sql-list-table): New functions. User API. + (sql-mode-map, sql-interactive-mode-map): Add key definitions + for above functions. + (sql-mode-menu, sql-interactive-mode-menu): Add menu definitions + for above functions. + (sql-postgres-login-params): Add user and database defaults. + (sql-buffer-live-p): Bug fix. + (sql-product-history): New variable. + (sql-read-product): New function. Use it. + (sql-set-product, sql-product-interactive): Use it. + (sql-connection-history): New variable. + (sql-read-connection): New function. Use it. + (sql-connect): New function. + (sql-for-each-login): Redesign function interface. + (sql-make-alternate-buffer-name, sql-save-connection): Use it. + (sql-get-login-ext, sql-get-login): Use it. Handle default values. + (sql-comint): Check for program. Existing live buffer. + (sql-comint-postgres): Add port parameter. + +2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/warnings.el: Fix commenting convention. + (display-warning): Use special mode and make the buffer read-only. + +2010-09-18 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-prog.el (calc-read-parse-table-part): Don't "fix" the + empty string when it follows a repeated or optional pattern. + +2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent.el (indent-according-to-mode): Apply syntax-propertize. + (indent-region): Use indent-according-to-mode. + +2010-09-18 Eli Zaretskii <eliz@gnu.org> + + * fringe.el (fringe-mode): Doc fix. + +2010-09-14 Kan-Ru Chen <kanru@kanru.info> (tiny change) + + * textmodes/nroff-mode.el (nroff-view): Kill old buffer before + refreshing the preview buffer. + +2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * textmodes/tex-mode.el (tex-syntax-propertize-rules) + (latex-syntax-propertize-rules): New consts; replace + tex-font-lock-syntactic-keywords. + (tex-env-mark, latex-env-before-change): New functions. + (latex-electric-env-pair-mode): New minor mode. + (tex-font-lock-verb): Change arguments; do move point. + (tex-font-lock-syntactic-face-function): Adjust to new verbatim + representation as a form of comment. + (tex-font-lock-keywords-1): Remove workaround, now unneeded. + (doctex-syntax-propertize-rules): New const; replaces + doctex-font-lock-syntactic-keywords. + (tex-common-initialization, doctex-mode): Use syntax-propertize-rules. + + * progmodes/fortran.el (fortran--font-lock-syntactic-keywords): Remove. + (fortran-make-syntax-propertize-function): New function; replaces + fortran-font-lock-syntactic-keywords. + (fortran-mode): Use it. + (fortran-line-length): Use it. Improve interactive spec. + + * emacs-lisp/syntax.el (syntax-propertize-precompile-rules): New macro. + (syntax-propertize-rules): Add var-ref case. Fix offset computation + when adding surrounding \(..\). + + * progmodes/js.el (js-mode): Fix last change (bug#7054). + +2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * obsolete/old-whitespace.el (whitespace-rescan-files-in-buffers): + Use with-current-buffer. + + * isearch.el (isearch-face): Rename from `isearch'. + (isearch-highlight): Use new name. + +2010-09-17 Eli Zaretskii <eliz@gnu.org> + + * fringe.el (fringe-mode, fringe-query-style): Use 4 pixels, not + 5, for `half' width fringes. (Bug#6933) + +2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/bytecomp.el (byte-compile-file-form-defvar) + (byte-compile-defvar): "foo/bar" does not lack a prefix. + + * subr.el (y-or-n-p): Add the "(y or n)" that was lost somehow. + +2010-09-17 Stephen Berman <stephen.berman@gmx.net> + + * dframe.el (dframe-reposition-frame-emacs): Use tool-bar-pixel-width + in calculating new frame position. Add more space between new and + parent on the left (Bug#7048). + +2010-09-17 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-compat.el (tramp-compat-with-temp-message): Make it a + defmacro. + +2010-09-16 Chong Yidong <cyd@stupidchicken.com> + + * mail/sendmail.el: Add "*unsent mail*" to same-window-buffer-names. + + * term/x-win.el (x-cut-buffer-or-selection-value): Define as + obsolete alias for x-selection-value. + + * ido.el (ido-make-buffer-list): Fix error in 2010-08-22 merge. + +2010-09-16 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-cmds.el (tramp-cleanup-connection): Set tramp-autoload + cookie. + +2010-09-15 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-compat.el (tramp-compat-with-temp-message) + (tramp-compat-font-lock-add-keywords, tramp-compat-process-get) + (tramp-compat-process-put): New defuns. + + * net/tramp.el (top): + * net/tramp-gvfs.el (top): + * net/tramp-cache.el (top): Use `tramp-compat-font-lock-add-keywords'. + + * net/tramp.el (tramp-progress-reporter-update): + Use `tramp-compat-funcall'. + + * net/tramp.el (tramp-process-actions): + * net/tramp-gvfs.el (tramp-handle-vc-registered): + * net/tramp-sh.el (tramp-gvfs-handler-askquestion) + (tramp-get-remote-stat, tramp-get-remote-readlink): + Use `tramp-compat-with-temp-message'. + + * net/tramp-sh.el (top): Require 'cl. + (tramp-handle-start-file-process): Use `tramp-compat-process-get'. + (tramp-open-connection-setup-interactive-shell): + Use `tramp-compat-process-put'. + +2010-09-15 Alan Mackenzie <acm@muc.de> + + * progmodes/cc-engine.el (c-forward-<>-arglist-recur): Correct the + indentation. + (c-forward-<>-arglist-recur): Fix an infinite recursion. + +2010-09-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/bytecomp.el (byte-compile-warning-types): New type + `lexical' for warnings related to lexical scoping. + (byte-compile-file-form-defvar, byte-compile-defvar): Warn about + global vars which don't have a prefix and could hence affect lexical + scoping in unrelated files. + +2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el: Revert back to version + cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes + seem problematic. + +2010-09-14 Juanma Barranquero <lekktu@gmail.com> + + * obsolete/old-whitespace.el (whitespace-unload-function): + Explicitly pass `obarray' to `unintern' to avoid a warning. + +2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/byte-run.el (set-advertised-calling-convention): + Add `when' argument. Update callers. + + * subr.el (unintern): Declare the obarray arg mandatory. + +2010-09-14 Glenn Morris <rgm@gnu.org> + + * calendar/diary-lib.el (diary-list-entries-hook, diary-sort-entries): + Doc fixes. + + * calendar/diary-lib.el (diary-included-files): New variable. + (diary-list-entries): Maybe initialize diary-included-files. + (diary-include-other-diary-files): Append to diary-included-files. + * calendar/appt.el (appt-update-list): Also check the members of + diary-included-files. (Bug#6999) + (appt-check): Doc fix. + +2010-09-14 David Reitter <david.reitter@gmail.com> + + * simple.el (line-move-visual): Do not truncate goal column to + integer size. (Bug#7020) + +2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca> + + * repeat.el (repeat): Allow repeating when the last event is a click. + Suggested by Drew Adams (bug#6256). + +2010-09-14 Sascha Wilde <wilde@sha-bang.de> + + * vc/vc-hg.el (vc-hg-state,vc-hg-working-revision): + Replace setting HGRCPATH to "" by some less invasive --config options. + +2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca> + + * font-lock.el (font-lock-beginning-of-syntax-function): + Mark as obsolete. + +2010-09-14 Glenn Morris <rgm@gnu.org> + + * menu-bar.el (menu-bar-options-save): Fix handling of menu-bar + and tool-bar modes. (Bug#6211) + (menu-bar-mode): Move setting of standard-value after the + minor-mode definition, otherwise it seems to have no effect. + +2010-09-14 Masatake YAMATO <yamato@redhat.com> + + * progmodes/antlr-mode.el (antlr-font-lock-additional-keywords): + Fix typo. (Bug#6976) + +2010-09-14 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * whitespace.el: Allow cleaning up blanks without blank + visualization (Bug#6651). Adjust help window for + whitespace-toggle-options (Bug#6479). Allow to use fill-column + instead of whitespace-line-column (from EmacsWiki). New version 13.1. + (whitespace-style): Add new value 'face. Adjust docstring. + (whitespace-space, whitespace-hspace, whitespace-tab): + Adjust foreground property face. + (whitespace-line-column): Adjust docstring and type declaration. + (whitespace-style-value-list, whitespace-toggle-option-alist) + (whitespace-help-text): Adjust const initialization. + (whitespace-toggle-options, global-whitespace-toggle-options): + Adjust docstring. + (whitespace-display-window, whitespace-interactive-char) + (whitespace-style-face-p, whitespace-color-on): Adjust code. + (whitespace-help-scroll): New fun. + +2010-09-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * calendar/time-date.el (format-seconds): Comment fix. + +2010-09-13 Michael R. Mauger <mmaug@yahoo.com> + + * progmodes/sql.el: Version 2.7. + (sql-buffer-live-p): Improve detection. + (sql-find-sqli-buffer, sql-set-sqli-buffer-generally) + (sql-set-sqli-buffer): Use it. + (sql-product-interactive): Run `sql-set-sqli-hook'. + (sql-rename-buffer): Code cleanup. + (sql-redirect, sql-redirect-value): New functions. More to come. + +2010-09-13 Juanma Barranquero <lekktu@gmail.com> + + Port tramp-related Makefile changes of revnos 101381, 101422 to Windows. + * makefile.w32-in (LOADDEFS): Add $(lisp)/net/tramp-loaddefs.el. + (TRAMP_SRC): New macro. + ($(lisp)/net/tramp-loaddefs.el): New target. + +2010-09-13 Michael Albinus <michael.albinus@gmx.de> + + Major code cleanup. Split tramp.el into tramp.el and tramp-sh.el. + + * Makefile.in (TRAMP_SRC): Remove tramp-fish.el. Add tramp-sh.el. + + * net/tramp.el (top): Don't show loading message. Require just + 'tramp-compat, everything else is required there. + Use `ignore-errors' where appropriate. + (tramp-inline-compress-start-size, tramp-copy-size-limit) + (tramp-terminal-type, tramp-end-of-output) + (tramp-initial-end-of-output, tramp-completion-function-alist-rsh) + (tramp-completion-function-alist-ssh) + (tramp-completion-function-alist-telnet) + (tramp-completion-function-alist-su) + (tramp-completion-function-alist-putty, tramp-remote-path) + (tramp-remote-process-environment, tramp-sh-extra-args) + (tramp-actions-before-shell, tramp-uudecode) + (tramp-perl-file-truename, tramp-perl-file-name-all-completions) + (tramp-perl-file-attributes) + (tramp-perl-directory-files-and-attributes) + (tramp-perl-encode-with-module, tramp-perl-decode-with-module) + (tramp-perl-encode, tramp-perl-decode) + (tramp-vc-registered-read-file-names, tramp-file-mode-type-map) + (tramp-file-name-handler-alist, tramp-make-tramp-temp-file) + (tramp-handle-make-symbolic-link, tramp-handle-load) + (tramp-handle-file-name-as-directory) + (tramp-handle-file-name-directory) + (tramp-handle-file-name-nondirectory, tramp-handle-file-truename) + (tramp-handle-file-exists-p, tramp-handle-file-attributes) + (tramp-do-file-attributes-with-ls) + (tramp-do-file-attributes-with-perl) + (tramp-do-file-attributes-with-stat) + (tramp-handle-set-visited-file-modtime) + (tramp-handle-verify-visited-file-modtime) + (tramp-handle-set-file-modes, tramp-handle-set-file-times) + (tramp-set-file-uid-gid, tramp-remote-selinux-p) + (tramp-handle-file-selinux-context) + (tramp-handle-set-file-selinux-context) + (tramp-handle-file-executable-p, tramp-handle-file-readable-p) + (tramp-handle-file-newer-than-file-p, tramp-handle-file-modes) + (tramp-handle-file-directory-p, tramp-handle-file-regular-p) + (tramp-handle-file-symlink-p, tramp-handle-file-writable-p) + (tramp-handle-file-ownership-preserved-p) + (tramp-handle-directory-file-name, tramp-handle-directory-files) + (tramp-handle-directory-files-and-attributes) + (tramp-do-directory-files-and-attributes-with-perl) + (tramp-do-directory-files-and-attributes-with-stat) + (tramp-handle-file-name-all-completions) + (tramp-handle-file-name-completion, tramp-handle-add-name-to-file) + (tramp-handle-copy-file, tramp-handle-copy-directory) + (tramp-handle-rename-file, tramp-do-copy-or-rename-file) + (tramp-do-copy-or-rename-file-via-buffer) + (tramp-do-copy-or-rename-file-directly) + (tramp-do-copy-or-rename-file-out-of-band) + (tramp-handle-make-directory, tramp-handle-delete-directory) + (tramp-handle-delete-file) + (tramp-handle-dired-recursive-delete-directory) + (tramp-handle-dired-compress-file, tramp-handle-dired-uncache) + (tramp-handle-insert-directory) + (tramp-handle-unhandled-file-name-directory) + (tramp-handle-expand-file-name) + (tramp-handle-substitute-in-file-name) + (tramp-handle-executable-find, tramp-process-sentinel) + (tramp-handle-start-file-process, tramp-handle-process-file) + (tramp-handle-call-process-region, tramp-handle-shell-command) + (tramp-handle-file-local-copy, tramp-handle-file-remote-p) + (tramp-handle-insert-file-contents) + (tramp-handle-insert-file-contents-literally) + (tramp-handle-find-backup-file-name) + (tramp-handle-make-auto-save-file-name, tramp-handle-write-region) + (tramp-vc-registered-file-names, tramp-handle-vc-registered) + (tramp-sh-file-name-handler, tramp-vc-file-name-handler) + (tramp-maybe-send-script, tramp-set-auto-save, tramp-run-test) + (tramp-run-test2, tramp-find-executable, tramp-set-remote-path) + (tramp-find-file-exists-command, tramp-open-shell) + (tramp-find-shell, tramp-barf-if-no-shell-prompt) + (tramp-open-connection-setup-interactive-shell) + (tramp-local-coding-commands, tramp-remote-coding-commands) + (tramp-find-inline-encoding, tramp-call-local-coding-command) + (tramp-inline-compress-commands, tramp-find-inline-compress) + (tramp-compute-multi-hops, tramp-maybe-open-connection) + (tramp-send-command , tramp-wait-for-output) + (tramp-send-command-and-check, tramp-barf-unless-okay) + (tramp-send-command-and-read, tramp-mode-string-to-int) + (tramp-convert-file-attributes, tramp-check-cached-permissions) + (tramp-file-mode-from-int, tramp-file-mode-permissions) + (tramp-shell-case-fold, tramp-make-copy-program-file-name) + (tramp-method-out-of-band-p, tramp-local-host-p) + (tramp-get-remote-path, tramp-get-remote-tmpdir) + (tramp-get-ls-command, tramp-get-ls-command-with-dired) + (tramp-get-test-command, tramp-get-test-nt-command) + (tramp-get-file-exists-command, tramp-get-remote-ln) + (tramp-get-remote-perl, tramp-get-remote-stat) + (tramp-get-remote-readlink, tramp-get-remote-trash) + (tramp-get-remote-id, tramp-get-remote-uid, tramp-get-remote-gid) + (tramp-get-local-uid, tramp-get-local-gid) + (tramp-get-inline-compress, tramp-get-inline-coding): Move to + tramp-sh.el. + (tramp-methods, tramp-default-method-alist) + (tramp-default-user-alist, tramp-foreign-file-name-handler-alist): + Move initialization to tramp-sh.el. + (tramp-temp-name-prefix): Make it a defconst. + (tramp-dissect-file-name): Don't check anymore for multi-hop + methods. + (tramp-debug-outline-regexp): Add a docstring. + (tramp-debug-outline-level): Rename from `tramp-outline-level'. + (tramp-get-debug-buffer): Use it. + + * net/tramp-cache.el (top): Set tramp-autoload cookie for + initialization forms. + (tramp-set-connection-property): Don't protect `tramp-message' + call, it isn't necessary any longer. + (tramp-dump-connection-properties): Use `ignore-errors'. + + * net/tramp-compat.el (top): Require 'advice, 'format-spec, + 'password-cache and 'auth-source. + + * net/tramp-gvfs.el (top): + * net/tramp-smb.el (top): Require 'tramp-sh. + + * net/tramp-gw.el (tramp-gw-open-network-stream): Use `ignore-errors'. + + * net/tramp-sh.el: New file, derived from tramp.el. + (top): Initialize `tramp-methods', `tramp-default-method-alist', + `tramp-default-user-alist', `tramp-foreign-file-name-handler-alist'. + Remove "scp1_old", "scp2_old", "ssh1_old", "ssh2_old". + Use `ignore-errors' where appropriate. + (tramp-sh-file-name-handler-alist): Rename from + `tramp-file-name-handler-alist'. + (tramp-send-command-and-check): Return t or nil. Remove all + `zerop' checks, where called. + (tramp-handle-set-file-modes) + (tramp-do-copy-or-rename-file-directly) + (tramp-handle-delete-directory, tramp-handle-delete-file) + (tramp-maybe-send-script): Use `tramp-barf-unless-okay'. + (tramp-sh-file-name-handler, tramp-send-command-and-check) + (tramp-get-remote-ln): Set tramp-autoload cookie. + + * net/tramp-fish.el: Remove file. + +2010-09-13 Daiki Ueno <ueno@unixuser.org> + + * epa-file.el (epa-file-insert-file-contents): If visiting, bind + buffer-file-name to avoid file-locking. (Bug#7026) + +2010-09-13 Julien Danjou <julien@danjou.info> + + * notifications.el (notifications-notify): Add support for + image-path and sound-name. + (notifications-specification-version): Add this variable. + +2010-09-12 Stefan Monnier <monnier@iro.umontreal.ca> + + * subr.el (y-or-n-p): New function, moved from src/fns.c; use read-key. + +2010-09-12 Leo <sdl.web@gmail.com> + + * net/rcirc.el (rcirc-server-commands, rcirc-client-commands) + (rcirc-completion-start): New variables. + (rcirc-nick-completions): Rename to rcirc-completions. + (rcirc-nick-completion-start-offset): Delete. + (rcirc-completion-at-point): New function for constructing + completion data for both nicks and irc commands. Add to + completion-at-point-functions in rcirc mode. + (rcirc-complete): Rename from rcirc-nick-complete; use + rcirc-completion-at-point. + (defun-rcirc-command): Update rcirc-client-commands. + +2010-09-11 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/bytecomp.el (byte-compile-file): Create .elc files + atomically, to avoid parallel build errors. (Bug#4196) + +2010-09-11 Michael R. Mauger <mmaug@yahoo.com> + + * progmodes/sql.el: Version 2.6 + (sql-dialect): Synonym for "sql-product". + (sql-find-sqli-buffer, sql-set-sqli-buffer-generally) + (sql-set-sqli-buffer, sql-show-sqli-buffer, sql-interactive-mode): + Set "sql-buffer" to buffer name not buffer object so multiple sql + interactive buffers work properly. Reverts misguided changes in + earlier work. + (sql-comint): Make sure different buffer name is used if "*SQL*" + buffer is for a different product. + (sql-make-alternate-buffer-name): Fix bug with "sql-database" + login param. + (sql-oracle, sql-sybase, sql-informix, sql-sqlite, sql-mysql) + (sql-solid, sql-ingres, sql-ms, sql-postgres, sql-interbase) + (sql-db2, sql-linter, sql-product-interactive, sql-rename-buffer): + Accept new buffer name or prompt for one. + (sql-port): Default to zero. + (sql-comint-mysql): Handle "sql-port" as a numeric. + (sql-port-history): Delete unused variable. + (sql-get-login): Default "sql-port" to a number. + (sql-product-alist): Correct Postgres prompt and terminator regexp. + (sql-sqlite-program): Dynamically detect presence of "sqlite" or + "sqlite3" executables. + (sql-sqlite-login-params): Add "*.sqlite[23]?" database name pattern. + (sql-buffer-live-p): New function. + (sql-mode-menu, sql-send-string): Use it. + (sql-mode-oracle-font-lock-keywords): Improve SQL*Plus REMARK + syntax pattern. + (sql-mode-postgres-font-lock-keywords): Support Postgres V9. + (sql-mode-sqlite-font-lock-keywords): Hilight sqlite commands. + +2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/netrc.el (netrc-credentials): New convenience function. + +2010-09-10 Stefan Monnier <monnier@iro.umontreal.ca> + + * textmodes/texinfo.el (texinfo-syntax-propertize-function): New fun + to replace texinfo-font-lock-syntactic-keywords. + (texinfo-mode): Use it. + + * textmodes/tex-mode.el (tex-common-initialization, doctex-mode): + Use syntax-propertize-function. + + * textmodes/sgml-mode.el (sgml-syntax-propertize-function): New var to + replace sgml-font-lock-syntactic-keywords. + (sgml-mode): Use it. + + * textmodes/reftex.el (font-lock-syntactic-keywords): Don't declare + since we don't use it. + + * textmodes/bibtex.el (bibtex-mode): Use syntax-propertize-function. + + * progmodes/vhdl-mode.el (vhdl-mode): Use syntax-propertize-function + if available. + (vhdl-fontify-buffer): Adjust. + + * progmodes/tcl.el (tcl-syntax-propertize-function): New var to + replace tcl-font-lock-syntactic-keywords. + (tcl-mode): Use it. + + * progmodes/simula.el (simula-syntax-propertize-function): New var to + replace simula-font-lock-syntactic-keywords. + (simula-mode): Use it. + + * progmodes/sh-script.el (sh-st-symbol): Remove. + (sh-font-lock-close-heredoc, sh-font-lock-open-heredoc): Add eol arg. + (sh-font-lock-flush-syntax-ppss-cache, sh-font-lock-here-doc): Remove. + (sh-font-lock-quoted-subshell): Assume we've already matched $(. + (sh-font-lock-paren): Set syntax-multiline. + (sh-font-lock-syntactic-keywords): Remove. + (sh-syntax-propertize-function): New function to replace it. + (sh-mode): Use it. + + * progmodes/ruby-mode.el (ruby-here-doc-beg-re): + Define while compiling. + (ruby-here-doc-end-re, ruby-here-doc-beg-match) + (ruby-font-lock-syntactic-keywords, ruby-comment-beg-syntax) + (syntax-ppss, ruby-in-ppss-context-p, ruby-in-here-doc-p) + (ruby-here-doc-find-end, ruby-here-doc-beg-syntax) + (ruby-here-doc-end-syntax): Only define when + syntax-propertize is not available. + (ruby-syntax-propertize-function, ruby-syntax-propertize-heredoc): + New functions. + (ruby-in-ppss-context-p): Update to new syntax of heredocs. + (electric-indent-chars): Silence bytecompiler. + (ruby-mode): Use prog-mode, syntax-propertize-function, and + electric-indent-chars. + + * progmodes/python.el (python-syntax-propertize-function): New var to + replace python-font-lock-syntactic-keywords. + (python-mode): Use it. + (python-quote-syntax): Simplify and adjust to new use. + + * progmodes/perl-mode.el (perl-syntax-propertize-function): New fun to + replace perl-font-lock-syntactic-keywords. + (perl-syntax-propertize-special-constructs): New fun to replace + perl-font-lock-special-syntactic-constructs. + (perl-font-lock-syntactic-face-function): New fun. + (perl-mode): Use it. + + * progmodes/octave-mod.el (octave-syntax-propertize-sqs): New function + to replace octave-font-lock-close-quotes. + (octave-syntax-propertize-function): New function to replace + octave-font-lock-syntactic-keywords. + (octave-mode): Use it. + + * progmodes/mixal-mode.el (mixal-syntax-propertize-function): New var; + replaces mixal-font-lock-syntactic-keywords. + (mixal-mode): Use it. + + * progmodes/make-mode.el (makefile-syntax-propertize-function): + New var; replaces makefile-font-lock-syntactic-keywords. + (makefile-mode): Use it. + (makefile-imake-mode): Adjust. + + * progmodes/js.el (js--regexp-literal): Define while compiling. + (js-syntax-propertize-function): New var; replaces + js-font-lock-syntactic-keywords. + (js-mode): Use it. + + * progmodes/gud.el (gdb-script-syntax-propertize-function): New var; + replaces gdb-script-font-lock-syntactic-keywords. + (gdb-script-mode): Use it. + + * progmodes/fortran.el (fortran-mode): Use syntax-propertize-function. + (fortran--font-lock-syntactic-keywords): New var. + (fortran-line-length): Update syntax-propertize-function and + fortran--font-lock-syntactic-keywords. + + * progmodes/cperl-mode.el (cperl-mode): Use syntax-propertize-function. + + * progmodes/cfengine.el (cfengine-mode): + Use syntax-propertize-function. + (cfengine-font-lock-syntactic-keywords): Remove. + + * progmodes/autoconf.el (autoconf-mode): + Use syntax-propertize-function. + (autoconf-font-lock-syntactic-keywords): Remove. + + * progmodes/ada-mode.el (ada-set-syntax-table-properties) + (ada-after-change-function, ada-initialize-syntax-table-properties) + (ada-handle-syntax-table-properties): Only define when + syntax-propertize is not available. + (ada-mode): Use syntax-propertize-function. + + * font-lock.el (font-lock-syntactic-keywords): Make obsolete. + (font-lock-fontify-syntactic-keywords-region): Move handling of + font-lock-syntactically-fontified to... + (font-lock-default-fontify-region): ...here. + Let syntax-propertize-function take precedence. + (font-lock-fontify-syntactically-region): Cal syntax-propertize. + + * emacs-lisp/syntax.el (syntax-propertize-function) + (syntax-propertize-chunk-size, syntax-propertize--done) + (syntax-propertize-extend-region-functions): New vars. + (syntax-propertize-wholelines, syntax-propertize-multiline) + (syntax-propertize--shift-groups, syntax-propertize-via-font-lock) + (syntax-propertize): New functions. + (syntax-propertize-rules): New macro. + (syntax-ppss-flush-cache): Set syntax-propertize--done. + (syntax-ppss): Call syntax-propertize. + + * emacs-lisp/regexp-opt.el (regexp-opt-depth): Skip named groups. + +2010-09-10 AgustÃn MartÃn <agustin.martin@hispalinux.es> + + * textmodes/ispell.el (ispell-init-process): Improve comments. + XEmacs compatibility changes regarding (add-hook) 'local option + and (set-process-query-on-exit-flag). + +2010-09-09 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-cache.el (tramp-parse-connection-properties): + Set tramp-autoload cookie. + +2010-09-09 Glenn Morris <rgm@gnu.org> + + * image.el (imagemagick-types-inhibit): Add :type, :version, :group. + (imagemagick-register-types): Doc fix. + +2010-09-08 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/octave-mod.el (electric-indent-chars): Silence bytecomp. + + * progmodes/js.el (require): Require is already "eval-and-compile". + (js--re-search-forward): Avoid `eval'. Preserve the error data. + (js--re-search-backward): Use js--re-search-forward. + + * progmodes/fortran.el (fortran-line-length): Don't recompute + syntactic keywords redundantly a second time. + + * progmodes/ada-mode.el: Replace "(set '" with setq. + (ada-mode): Simplify. + (ada-create-case-exception, ada-adjust-case-interactive) + (ada-adjust-case-region, ada-format-paramlist, ada-indent-current) + (ada-search-ignore-string-comment, ada-move-to-start) + (ada-move-to-end): Use with-syntax-table. + + * font-lock.el (save-buffer-state): Remove `varlist' arg. + (font-lock-unfontify-region, font-lock-default-fontify-region): + Update usage correspondingly. + (font-lock-fontify-syntactic-keywords-region): + Set parse-sexp-lookup-properties buffer-locally here. + (font-lock-fontify-syntactically-region): Remove unused `ppss' arg. + + * simple.el (blink-matching-open): Don't burp if we can't find a match. + +2010-09-08 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/bytecomp.el (byte-compile-report-ops): + Error if not compiled with -DBYTE_CODE_METER. + + * emacs-lisp/bytecomp.el (byte-recompile-directory): + Ignore dir-locals-file. + +2010-09-08 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/compile.el (compilation-error-regexp-alist-alist): + Not a const. + (compilation-error-regexp-alist-alist): Rule out ": " in file names + for the `gnu' messages. + (compilation-set-skip-threshold): New command. + (compilation-start): Use \' rather than $. + (compilation-forget-errors): Use clrhash. + +2010-09-08 AgustÃn MartÃn <agustin.martin@hispalinux.es> + + * textmodes/ispell.el (ispell-valid-dictionary-list): + Simplify logic. + +2010-09-08 Michael Albinus <michael.albinus@gmx.de> + + Migrate to Tramp 2.2. Rearrange load dependencies. + (Bug#1529, Bug#5448, Bug#5705) + + * Makefile.in (TRAMP_DIR, TRAMP_SRC): New variables. + ($(TRAMP_DIR)/tramp-loaddefs.el): New target. + (LOADDEFS): Add $(lisp)/net/tramp-loaddefs.el. + + * net/tramp.el (top): Remove all other tramp-* loads except + tramp-compat.el. Remove all changes to tramp-unload-hook for + other tramp-* packages. Rearrange defun order. Change calls of + `tramp-compat-call-process', `tramp-compat-decimal-to-octal', + `tramp-compat-octal-to-decimal' to new function names. + (tramp-terminal-type, tramp-initial-end-of-output) + (tramp-methods, tramp-foreign-file-name-handler-alist) + (tramp-tramp-file-p, tramp-completion-mode-p) + (tramp-send-command-and-check, tramp-get-remote-path) + (tramp-get-remote-tmpdir, tramp-get-remote-ln) + (tramp-shell-quote-argument): Set tramp-autoload cookie. + (with-file-property, with-connection-property): Move to + tramp-cache.el. + (tramp-local-call-process, tramp-decimal-to-octal) + (tramp-octal-to-decimal): Move to tramp-compat.el. + (tramp-handle-shell-command): Do not require 'shell. + (tramp-compute-multi-hops): No special handling for tramp-gw-* + symbols. + (tramp-unload-tramp): Do not call `tramp-unload-file-name-handlers'. + + * net/tramp-cache.el (top): Require 'tramp. Add to + `tramp-unload-hook'. + (tramp-cache-data, tramp-get-file-property) + (tramp-set-file-property, tramp-flush-file-property) + (tramp-flush-directory-property, tramp-get-connection-property) + (tramp-set-connection-property, tramp-flush-connection-property) + (tramp-cache-print, tramp-list-connections): Set tramp-autoload + cookie. + (with-file-property, with-connection-property): New defuns, moved + from tramp.el. + (tramp-flush-file-function): Use `with-parsed-tramp-file-name' + macro. + + * net/tramp-cmds.el (top): Add to `tramp-unload-hook'. + (tramp-version): Set tramp-autoload cookie. + + * net/tramp-compat.el (top): Require 'tramp-loaddefs. Remove all + changes to tramp-unload-hook for other tramp-* packages. Add to + `tramp-unload-hook'. + (tramp-compat-decimal-to-octal, tramp-compat-octal-to-decimal) + (tramp-compat-call-process): New defuns, moved from tramp.el. + + * net/tramp-fish.el (top) Require just 'tramp. Add objects to + `tramp-methods' and `tramp-foreign-file-name-handler-alist'. Add + to `tramp-unload-hook'. Change call of + `tramp-compat-decimal-to-octal' to new function name. + (tramp-fish-method): Make it a defconst. + (tramp-fish-file-name-p): Make it a defsubst. + (tramp-fish-method, tramp-fish-file-name-handler) + (tramp-fish-file-name-p): Set tramp-autoload cookie. + + * net/tramp-ftp.el (top) Add objects to `tramp-methods' and + `tramp-foreign-file-name-handler-alist'. Add to + `tramp-unload-hook'. + (tramp-ftp-method): Make it a defconst. + (tramp-ftp-file-name-p): Make it a defsubst. + (tramp-ftp-method, tramp-ftp-file-name-handler) + (tramp-ftp-file-name-p): Set tramp-autoload cookie. + + * net/tramp-gvfs.el (top) Add objects to `tramp-methods' and + `tramp-foreign-file-name-handler-alist'. Add to + `tramp-unload-hook'. Change checks, whether package can be + loaded. + (tramp-gvfs-file-name-p): Make it a defsubst. + (tramp-gvfs-methods, tramp-gvfs-file-name-handler) + (tramp-gvfs-file-name-p): Set tramp-autoload cookie. + (tramp-gvfs-handle-file-directory-p): New defun. + (tramp-gvfs-file-name-handler-alist): Use it. + + * net/tramp-gw.el (top) Add objects to `tramp-methods' and + `tramp-foreign-file-name-handler-alist'. Add to + `tramp-unload-hook'. + (tramp-gw-tunnel-method, tramp-gw-default-tunnel-port) + (tramp-gw-socks-method, tramp-gw-default-socks-port): Make it a + defconst. + (tramp-gw-tunnel-method, tramp-gw-socks-method) + (tramp-gw-open-connection): Set tramp-autoload cookie. + + * net/tramp-imap.el (top) Require just 'tramp. Add objects to + `tramp-methods' and `tramp-foreign-file-name-handler-alist'. Add + to `tramp-unload-hook'. Change checks, whether package can be + loaded. + (tramp-imap-file-name-p): Make it a defsubst. + (tramp-imap-method, tramp-imaps-method) + (tramp-imap-file-name-handler) + (tramp-imap-file-name-p): Set tramp-autoload cookie. + + * net/tramp-smb.el (top) Require just 'tramp. Add objects to + `tramp-methods' and `tramp-foreign-file-name-handler-alist'. Add + to `tramp-unload-hook'. Change checks, whether package can be + loaded. Change call of `tramp-compat-decimal-to-octal' to new + function name. + (tramp-smb-tunnel-method): Make it a defconst. + (tramp-smb-file-name-p): Make it a defsubst. + (tramp-smb-method, tramp-smb-file-name-handler) + (tramp-smb-file-name-p): Set tramp-autoload cookie. + + * net/tramp-uu.el (top) Add to `tramp-unload-hook'. + (tramp-uuencode-region): Set tramp-autoload cookie. + + * net/trampver.el (top) Add to `tramp-unload-hook'. + (tramp-version, tramp-bug-report-address): Set tramp-autoload + cookie. Update release number. + 2010-09-07 AgustÃn MartÃn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-start-process): Make sure original @@ -22,7 +887,7 @@ 2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> - * net/imap.el (imap-message-map): Removed optional buffer parameter, + * net/imap.el (imap-message-map): Remove optional buffer parameter, since no callers use it. (imap-message-get): Ditto. (imap-message-put): Ditto. @@ -33,11 +898,11 @@ 2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> - * net/imap.el (imap-fetch-safe): Removed function, and altered all + * net/imap.el (imap-fetch-safe): Remove function, and alter all callers to use `imap-fetch' instead. According to the comments, this should be safe, since all other IMAP clients use the 1:* syntax. - (imap-enable-exchange-bug-workaround): Removed. - (imap-debug): Removed -- doesn't seem very useful. + (imap-enable-exchange-bug-workaround): Remove. + (imap-debug): Remove -- doesn't seem very useful. 2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -168,7 +1033,7 @@ `default-directory' unless using Ispell per-directory personal dictionaries and not in a mini-buffer under XEmacs. (kill-buffer-hook): Do not kill ispell process on exit when - `ispell-process-directory' is "~/". (Bug#6143) + `ispell-process-directory' is "~/". (Bug#6143) 2010-09-02 Jan Djärv <jan.h.d@swipnet.se> @@ -545,8 +1410,8 @@ (tramp-gvfs-mount-spec): Return both prefix and mountspec. (tramp-gvfs-maybe-open-connection): Test, whether mountpoint exists. Raise an error, if not (due to a corresponding answer - "no" in interactive questions, for example). Use - `tramp-compat-funcall'. + "no" in interactive questions, for example). + Use `tramp-compat-funcall'. * net/tramp-imap.el (top): Autoload `epg-make-context'. (tramp-imap-handle-copy-file): Add PRESERVE-SELINUX-CONTEXT. @@ -1278,10 +2143,10 @@ 2010-08-08 Stephen Peters <speters@itasoftware.com> * calendar/icalendar.el - (icalendar--split-value): Fixed splitting regexp. (Bug#6766) - (icalendar--get-weekday-numbers): New + (icalendar--split-value): Fix splitting regexp. (Bug#6766) + (icalendar--get-weekday-numbers): New. (icalendar--convert-recurring-to-diary): Handle multiple byday - values in weekly rules. (Bug#6766) + values in weekly rules. (Bug#6766) 2010-08-08 Ulf Jasper <ulf.jasper@web.de> @@ -4915,7 +5780,7 @@ Enable recentf-mode if using virtual buffers. * ido.el (recentf-list): Declare for byte-compiler. - (ido-virtual-buffers): Move up to silence byte-compiler. Add docstring. + (ido-virtual-buffers): Move up to silence byte-compiler. Add docstring. (ido-make-buffer-list): Simplify. (ido-add-virtual-buffers-to-list): Simplify. Enable recentf-mode.
--- a/lisp/ChangeLog.10 Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ChangeLog.10 Wed Sep 22 15:46:51 2010 +0900 @@ -4757,7 +4757,7 @@ * files.el (insert-directory): Decode by what specified. * language/japan-util.el (setup-japanese-environment-internal): - By defalt, use japanese-iso-8bit for file names, and prefer + By default, use japanese-iso-8bit for file names, and prefer japanese-shift-jis on DOS and Windows. * international/quail.el (quail-show-guidance-buf): Make the quail @@ -21636,7 +21636,7 @@ 2001-11-26 Sam Steingold <sds@gnu.org> * frame.el (show-trailing-whitespace): Remove :set argument (the - value was essentially identical to the defalt). + value was essentially identical to the default). 2001-11-26 Pavel JanÃk <Pavel@Janik.cz>
--- a/lisp/ChangeLog.11 Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ChangeLog.11 Wed Sep 22 15:46:51 2010 +0900 @@ -2000,7 +2000,7 @@ (math-rewrite, math-rewrite-phase): Replace variable expr by declared variable. (math-rewrite-heads-heads, math-rewrite-heads-skips) - (math-rewrite-heads-blanks ): New variables. + (math-rewrite-heads-blanks): New variables. (math-rewrite-heads, math-rewrite-heads-rec): Replace variables heads, skips and blanks by declared variables. (math-rwcomp-subst-old, math-rwcomp-subst-new) @@ -11832,7 +11832,7 @@ (ido-saved-vc-hb): Rename from ido-saved-vc-mt. Uses changed. (ido-no-final-slash): New defun. (ido-make-prompt, ido-file-internal, ido-toggle-vc) - (ido-read-file-name): ): Toggle VC checking via + (ido-read-file-name): Toggle VC checking via vc-handled-backends instead of vc-master-templates. (ido-file-internal): Handle ido-use-url-at-point and ido-use-filename-at-point via code borrowed from ffap-guesser.
--- a/lisp/ChangeLog.13 Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ChangeLog.13 Wed Sep 22 15:46:51 2010 +0900 @@ -7567,7 +7567,7 @@ (ediff-setup-windows-plain-merge) (ediff-setup-windows-plain-compare, ediff-setup-control-frame) (ediff-refresh-control-frame, ediff-get-visible-buffer-window): - * ediff-util.el (ediff-setup-keymap, ) + * ediff-util.el (ediff-setup-keymap) (ediff-toggle-wide-display, ediff-toggle-multiframe) (ediff-toggle-use-toolbar, ediff-really-quit) (ediff-good-frame-under-mouse)
--- a/lisp/Makefile.in Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/Makefile.in Wed Sep 22 15:46:51 2010 +0900 @@ -56,7 +56,8 @@ LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \ $(lisp)/calendar/diary-loaddefs.el \ $(lisp)/calendar/hol-loaddefs.el \ - $(lisp)/mh-e/mh-loaddefs.el + $(lisp)/mh-e/mh-loaddefs.el \ + $(lisp)/net/tramp-loaddefs.el # Elisp files auto-generated. AUTOGENEL = loaddefs.el \ @@ -329,6 +330,24 @@ --eval "(setq make-backup-files nil)" \ -f batch-update-autoloads $(MH_E_DIR) +# Update TRAMP internal autoloads. Maybe we could move trmp*.el into +# an own subdirectory. OTOH, it does not hurt to keep them in +# lisp/net. +TRAMP_DIR = $(lisp)/net +TRAMP_SRC = $(TRAMP_DIR)/tramp.el $(TRAMP_DIR)/tramp-cache.el \ + $(TRAMP_DIR)/tramp-cmds.el $(TRAMP_DIR)/tramp-compat.el \ + $(TRAMP_DIR)/tramp-ftp.el $(TRAMP_DIR)/tramp-gvfs.el \ + $(TRAMP_DIR)/tramp-gw.el $(TRAMP_DIR)/tramp-imap.el \ + $(TRAMP_DIR)/tramp-sh.el $(TRAMP_DIR)/tramp-smb.el \ + $(TRAMP_DIR)/tramp-uu.el $(TRAMP_DIR)/trampver.el + +$(TRAMP_DIR)/tramp-loaddefs.el: $(TRAMP_SRC) + $(emacs) -l autoload \ + --eval "(setq generate-autoload-cookie \";;;###tramp-autoload\")" \ + --eval "(setq generated-autoload-file \"$@\")" \ + --eval "(setq make-backup-files nil)" \ + -f batch-update-autoloads $(TRAMP_DIR) + CAL_DIR = $(lisp)/calendar ## Those files that may contain internal calendar autoload cookies. ## Avoids circular dependency warning for *-loaddefs.el.
--- a/lisp/ansi-color.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ansi-color.el Wed Sep 22 15:46:51 2010 +0900 @@ -244,9 +244,9 @@ (when (boundp 'font-lock-syntactic-keywords) (remove-text-properties beg end '(syntax-table nil))) ;; instead of just using (remove-text-properties beg end '(face - ;; nil)), we find regions with a non-nil face test-property, skip + ;; nil)), we find regions with a non-nil face text-property, skip ;; positions with the ansi-color property set, and remove the - ;; remaining face test-properties. + ;; remaining face text-properties. (while (setq beg (text-property-not-all beg end 'face nil)) (setq beg (or (text-property-not-all beg end 'ansi-color t) end)) (when (get-text-property beg 'face)
--- a/lisp/calc/calc-prog.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/calc/calc-prog.el Wed Sep 22 15:46:51 2010 +0900 @@ -627,7 +627,8 @@ (error "Separator not allowed with { ... }?")) (if (string-match "\\`\"" sep) (setq sep (read-from-string sep))) - (setq sep (calc-fix-token-name sep)) + (if (> (length sep) 0) + (setq sep (calc-fix-token-name sep))) (setq part (nconc part (list (list sym p (and (> (length sep) 0)
--- a/lisp/calendar/appt.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/calendar/appt.el Wed Sep 22 15:46:51 2010 +0900 @@ -48,8 +48,9 @@ ;; package is activated. Additionally, the appointments list is ;; recreated automatically at 12:01am for those who do not logout ;; every day or are programming late. It is also updated when the -;; `diary-file' is saved. Calling `appt-check' with an argument (or -;; re-enabling the package) forces a re-initialization at any time. +;; `diary-file' (or a file it includes) is saved. Calling +;; `appt-check' with an argument (or re-enabling the package) forces a +;; re-initialization at any time. ;; ;; In order to add or delete items from today's list, without ;; changing the diary file, use `appt-add' and `appt-delete'. @@ -262,7 +263,7 @@ "Check for an appointment and update any reminder display. If optional argument FORCE is non-nil, reparse the diary file for appointments. Otherwise the diary file is only parsed once per day, -and when saved. +or when it (or a file it includes) is saved. Note: the time must be the first thing in the line in the diary for a warning to be issued. The format of the time can be either @@ -346,6 +347,8 @@ (if d-buff ; diary buffer exists (with-current-buffer d-buff diary-selective-display)))) + ;; FIXME why not using diary-list-entries with + ;; non-nil LIST-ONLY? (diary) ;; If the diary buffer existed before this command, ;; restore its display state. Otherwise, kill it. @@ -643,8 +646,10 @@ (defun appt-update-list () "If the current buffer is visiting the diary, update appointments. -This function is intended for use with `write-file-functions'." - (and (string-equal buffer-file-name (expand-file-name diary-file)) +This function also acts on any file listed in `diary-included-files'. +It is intended for use with `write-file-functions'." + (and (member buffer-file-name (append diary-included-files + (list (expand-file-name diary-file)))) appt-timer (let ((appt-display-diary nil)) (appt-check t)))
--- a/lisp/calendar/diary-lib.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/calendar/diary-lib.el Wed Sep 22 15:46:51 2010 +0900 @@ -187,11 +187,12 @@ (setq diary-display-function 'diary-fancy-display) (add-hook 'diary-list-entries-hook 'diary-include-other-diary-files) - (add-hook 'diary-list-entries-hook 'diary-sort-entries) + (add-hook 'diary-list-entries-hook 'diary-sort-entries t) in your `.emacs' file to cause the fancy diary buffer to be displayed with diary entries from various included files, each day's entries sorted into -lexicographic order." +lexicographic order. Note how the sort function is placed last, +so that it can sort the entries included from other files." :type 'hook :options '(diary-include-other-diary-files diary-sort-entries) :group 'diary) @@ -699,6 +700,10 @@ (1+ (calendar-absolute-from-gregorian gdate)))))) (goto-char (point-min))) +(defvar diary-including) ; dynamically bound in diary-include-other-diary-files +(defvar diary-included-files nil + "List of any diary files included in the last call to `diary-list-entries'.") + ;; FIXME non-greg and list hooks run same number of times? (defun diary-list-entries (date number &optional list-only) "Create and display a buffer containing the relevant lines in `diary-file'. @@ -743,6 +748,8 @@ (date-string (calendar-date-string date)) (diary-buffer (find-buffer-visiting diary-file)) diary-entries-list file-glob-attrs) + (or (bound-and-true-p diary-including) + (setq diary-included-files nil)) (message "Preparing diary...") (save-current-buffer (if (not diary-buffer) @@ -828,11 +835,15 @@ (let ((diary-file (match-string-no-properties 1)) (diary-list-entries-hook 'diary-include-other-diary-files) (diary-display-function 'ignore) + (diary-including t) diary-hook diary-list-include-blanks) (if (file-exists-p diary-file) (if (file-readable-p diary-file) (unwind-protect - (setq diary-entries-list + (setq diary-included-files + (append diary-included-files + (list (expand-file-name diary-file))) + diary-entries-list (append diary-entries-list (diary-list-entries original-date number))) (with-current-buffer (find-buffer-visiting diary-file) @@ -1574,7 +1585,10 @@ (string-lessp ts1 ts2))))))) (defun diary-sort-entries () - "Sort the list of diary entries by time of day." + "Sort the list of diary entries by time of day. +If you add this function to `diary-list-entries-hook', it should +be the last item in the hook, in case earlier items add diary +entries, or change the order." (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) (define-obsolete-function-alias 'sort-diary-entries 'diary-sort-entries "23.1")
--- a/lisp/calendar/time-date.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/calendar/time-date.el Wed Sep 22 15:46:51 2010 +0900 @@ -317,10 +317,10 @@ (setq start (match-end 0) spec (match-string 1 string)) (unless (string-equal spec "%") - ;; `assoc-string' is not available in Emacs 21. So when compiling - ;; Gnus (`time-date.el' is part of Gnus) with Emacs 21, we get a - ;; warning here. But `format-seconds' is not used anywhere in Gnus so - ;; it's not a real problem. --rsteib + ;; `assoc-string' is not available in XEmacs or Emacs 21. So when + ;; compiling Gnus (`time-date.el' is part of Gnus) with XEmacs or + ;; Emacs 21, we get a warning here. But `format-seconds' is not + ;; used anywhere in Gnus so it's not a real problem. --rsteib (or (setq match (assoc-string spec units t)) (error "Bad format specifier: `%s'" spec)) (if (assoc-string spec usedunits t)
--- a/lisp/dframe.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/dframe.el Wed Sep 22 15:46:51 2010 +0900 @@ -430,7 +430,8 @@ (unless (or (not window-system) (eq window-system 'pc)) (let* ((pfx (dframe-frame-parameter parent-frame 'left)) (pfy (dframe-frame-parameter parent-frame 'top)) - (pfw (frame-pixel-width parent-frame)) + (pfw (+ (tool-bar-pixel-width parent-frame) + (frame-pixel-width parent-frame))) (pfh (frame-pixel-height parent-frame)) (nfw (frame-pixel-width new-frame)) (nfh (frame-pixel-height new-frame)) @@ -459,7 +460,7 @@ (- (x-display-pixel-height) (car (cdr pfy)) pfh) (car (cdr pfy))))) (cond ((eq location 'right) - (setq newleft (+ pfx pfw 5) + (setq newleft (+ pfx pfw 10) newtop pfy)) ((eq location 'left) (setq newleft (- pfx 10 nfw) @@ -471,7 +472,7 @@ ;; extra 10 is just dressings for window ;; decorations. (let* ((left-guess (- pfx 10 nfw)) - (right-guess (+ pfx pfw 5)) + (right-guess (+ pfx pfw 10)) (left-margin left-guess) (right-margin (- (x-display-pixel-width) right-guess 5 nfw)))
--- a/lisp/emacs-lisp/byte-run.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/byte-run.el Wed Sep 22 15:46:51 2010 +0900 @@ -108,10 +108,11 @@ (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) -(defun set-advertised-calling-convention (function signature) +(defun set-advertised-calling-convention (function signature when) "Set the advertised SIGNATURE of FUNCTION. This will allow the byte-compiler to warn the programmer when she uses -an obsolete calling convention." +an obsolete calling convention. WHEN specifies since when the calling +convention was modified." (puthash (indirect-function function) signature advertised-signature-table)) @@ -132,7 +133,7 @@ obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. - 'make-obsolete '(obsolete-name current-name when)) + 'make-obsolete '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-function-alias (obsolete-name current-name &optional when docstring) @@ -153,7 +154,7 @@ (set-advertised-calling-convention ;; New code should always provide the `when' argument. 'define-obsolete-function-alias - '(obsolete-name current-name when &optional docstring)) + '(obsolete-name current-name when &optional docstring) "23.1") (defun make-obsolete-variable (obsolete-name current-name &optional when) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. @@ -175,7 +176,7 @@ obsolete-name) (set-advertised-calling-convention ;; New code should always provide the `when' argument. - 'make-obsolete-variable '(obsolete-name current-name when)) + 'make-obsolete-variable '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-variable-alias (obsolete-name current-name &optional when docstring) @@ -210,7 +211,7 @@ (set-advertised-calling-convention ;; New code should always provide the `when' argument. 'define-obsolete-variable-alias - '(obsolete-name current-name when &optional docstring)) + '(obsolete-name current-name when &optional docstring) "23.1") ;; FIXME This is only defined in this file because the variable- and ;; function- versions are too. Unlike those two, this one is not used
--- a/lisp/emacs-lisp/bytecomp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/bytecomp.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,8 @@ ;;; bytecomp.el --- compilation of Lisp code into byte code ;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002, -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Jamie Zawinski <jwz@lucid.com> ;; Hallvard Furuseth <hbf@ulrik.uio.no> @@ -264,7 +265,7 @@ (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious) + make-local mapcar constants suspicious lexical) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -1548,6 +1549,9 @@ (if (and (string-match emacs-lisp-file-regexp bytecomp-source) (file-readable-p bytecomp-source) (not (auto-save-file-name-p bytecomp-source)) + (not (string-equal dir-locals-file + (file-name-nondirectory + bytecomp-source))) (setq bytecomp-dest (byte-compile-dest-file bytecomp-source)) (if (file-exists-p bytecomp-dest) @@ -1694,17 +1698,25 @@ (insert "\n") ; aaah, unix. (if (file-writable-p target-file) ;; We must disable any code conversion here. - (let ((coding-system-for-write 'no-conversion)) + (let ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile (make-temp-name target-file))) (if (memq system-type '(ms-dos 'windows-nt)) (setq buffer-file-type t)) - (when (file-exists-p target-file) - ;; Remove the target before writing it, so that any - ;; hard-links continue to point to the old file (this makes - ;; it possible for installed files to share disk space with - ;; the build tree, without causing problems when emacs-lisp - ;; files in the build tree are recompiled). - (delete-file target-file)) - (write-region (point-min) (point-max) target-file)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (rename-file tempfile target-file t) + (message "Wrote %s" target-file)) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" @@ -2141,6 +2153,11 @@ ;; Since there is no doc string, we can compile this as a normal form, ;; and not do a file-boundary. (byte-compile-keep-pending form) + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "Global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (push (nth 1 form) byte-compile-bound-variables) (if (eq (car form) 'defconst) (push (nth 1 form) byte-compile-const-variables)) @@ -3792,6 +3809,11 @@ (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. + (when (and (symbolp (nth 1 form)) + (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + (byte-compile-warning-enabled-p 'lexical)) + (byte-compile-warn "Global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) @@ -4240,6 +4262,8 @@ (defvar byte-code-meter) (defun byte-compile-report-ops () + (or (boundp 'byte-metering-on) + (error "You must build Emacs with -DBYTE_CODE_METER to use this")) (with-output-to-temp-buffer "*Meter*" (set-buffer "*Meter*") (let ((i 0) n op off)
--- a/lisp/emacs-lisp/lisp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/lisp.el Wed Sep 22 15:46:51 2010 +0900 @@ -141,15 +141,19 @@ This command assumes point is not in a string or comment." (interactive "^p") (or arg (setq arg 1)) - (let ((inc (if (> arg 0) 1 -1))) + (let ((inc (if (> arg 0) 1 -1)) + pos) (while (/= arg 0) - (if forward-sexp-function + (if (null forward-sexp-function) + (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) (condition-case err - (while (let ((pos (point))) + (while (progn (setq pos (point)) (forward-sexp inc) (/= (point) pos))) (scan-error (goto-char (nth 2 err)))) - (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))) + (if (= (point) pos) + (signal 'scan-error + (list "Unbalanced parentheses" (point) (point))))) (setq arg (- arg inc))))) (defun kill-sexp (&optional arg)
--- a/lisp/emacs-lisp/regexp-opt.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/regexp-opt.el Wed Sep 22 15:46:51 2010 +0900 @@ -120,7 +120,7 @@ (string-match regexp "") ;; Count the number of open parentheses in REGEXP. (let ((count 0) start last) - (while (string-match "\\\\(\\(\\?:\\)?" regexp start) + (while (string-match "\\\\(\\(\\?[0-9]*:\\)?" regexp start) (setq start (match-end 0)) ; Start of next search. (when (and (not (match-beginning 1)) (subregexp-context-p regexp (match-beginning 0) last))
--- a/lisp/emacs-lisp/smie.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/smie.el Wed Sep 22 15:46:51 2010 +0900 @@ -159,7 +159,8 @@ (last-nts ()) (first-nts ())) (dolist (rhs (cdr rules)) - (assert (consp rhs)) + (unless (consp rhs) + (signal 'wrong-type-argument `(consp ,rhs))) (if (not (member (car rhs) nts)) (pushnew (car rhs) first-ops) (pushnew (car rhs) first-nts) @@ -307,6 +308,40 @@ (nreverse alist))) +(defun smie-debug--prec2-cycle (csts) + "Return a cycle in CSTS, assuming there's one. +CSTS is a list of pairs representing arcs in a graph." + ;; A PATH is of the form (START . REST) where REST is a reverse + ;; list of nodes through which the path goes. + (let ((paths (mapcar (lambda (pair) (list (car pair) (cdr pair))) csts)) + (cycle nil)) + (while (null cycle) + (dolist (path (prog1 paths (setq paths nil))) + (dolist (cst csts) + (when (eq (car cst) (nth 1 path)) + (if (eq (cdr cst) (car path)) + (setq cycle path) + (push (cons (car path) (cons (cdr cst) (cdr path))) + paths)))))) + (cons (car cycle) (nreverse (cdr cycle))))) + +(defun smie-debug--describe-cycle (table cycle) + (let ((names + (mapcar (lambda (val) + (let ((res nil)) + (dolist (elem table) + (if (eq (cdr elem) val) + (push (concat "." (car elem)) res)) + (if (eq (cddr elem) val) + (push (concat (car elem) ".") res))) + (assert res) + res)) + cycle))) + (mapconcat + (lambda (elems) (mapconcat 'identity elems "=")) + (append names (list (car names))) + " < "))) + (defun smie-prec2-levels (prec2) ;; FIXME: Rather than only return an alist of precedence levels, we should ;; also extract other useful data from it: @@ -387,7 +422,9 @@ (incf i)) (setq csts (delq cst csts)))) (unless progress - (error "Can't resolve the precedence table to precedence levels"))) + (error "Can't resolve the precedence cycle: %s" + (smie-debug--describe-cycle + table (smie-debug--prec2-cycle csts))))) (incf i 10)) ;; Propagate equalities back to their source. (dolist (eq (nreverse eqs)) @@ -450,7 +487,7 @@ (skip-syntax-forward "w_'")) (point)))) -(defun smie-associative-p (toklevels) +(defun smie--associative-p (toklevels) ;; in "a + b + c" we want to stop at each +, but in ;; "if a then b elsif c then d else c" we don't want to stop at each keyword. ;; To distinguish the two cases, we made smie-prec2-levels choose @@ -535,13 +572,13 @@ ;; If the new operator is not the last in the BNF rule, ;; ans is not associative, it's one of the inner operators ;; (like the "in" in "let .. in .. end"), so keep looking. - ((not (smie-associative-p toklevels)) + ((not (smie--associative-p toklevels)) (push toklevels levels)) ;; The new operator is associative. Two cases: ;; - it's really just an associative operator (like + or ;) ;; in which case we should have stopped right before. ((and lastlevels - (smie-associative-p (car lastlevels))) + (smie--associative-p (car lastlevels))) (throw 'return (prog1 (list (or (car toklevels) t) (point) token) (goto-char pos)))) @@ -720,6 +757,7 @@ ;; This not is one of the begin..end we know how to check. (blink-matching-check-mismatch start end)) ((not start) t) + ((eq t (car (rassoc ender smie-closer-alist))) nil) (t (goto-char start) (let ((starter (funcall smie-forward-token-function))) @@ -732,45 +770,42 @@ smie-closer-alist ; Optimization. (eq (char-before) last-command-event) ; Sanity check. (memq last-command-event smie-blink-matching-triggers) - (save-excursion - ;; FIXME: Here we assume that closers all end - ;; with a word-syntax char. - (unless (eq ?\w (char-syntax last-command-event)) - (forward-char -1)) - (and (looking-at "\\>") - (not (nth 8 (syntax-ppss)))))) + (not (nth 8 (syntax-ppss)))) (save-excursion (let ((pos (point)) (token (funcall smie-backward-token-function))) - (if (= 1 (length token)) - ;; The trigger char is itself a token but is not - ;; one of the closers (e.g. ?\; in Octave mode), - ;; so go back to the previous token - (setq token (save-excursion - (funcall smie-backward-token-function))) - (goto-char pos)) - ;; Here we assume that smie-backward-token-function - ;; returns a token that is a string and whose content - ;; match the buffer's representation of this token. - (when (and (> (length token) 1) (stringp token) - (memq (aref token (1- (length token))) - smie-blink-matching-triggers) - (not (eq (aref token (1- (length token))) - last-command-event))) - ;; Token ends with a trigger char, so don't blink for - ;; anything else than this trigger char, lest we'd blink - ;; both when inserting the trigger char and when inserting a - ;; subsequent SPC. - (setq token nil)) - (when (and (rassoc token smie-closer-alist) - (or smie-blink-matching-inners - (null (nth 2 (assoc token smie-op-levels))))) - ;; The major mode might set blink-matching-check-function - ;; buffer-locally so that interactive calls to - ;; blink-matching-open work right, but let's not presume - ;; that's the case. - (let ((blink-matching-check-function #'smie-blink-matching-check)) - (blink-matching-open))))))) + (when (and (eq (point) (1- pos)) + (= 1 (length token)) + (not (rassoc token smie-closer-alist))) + ;; The trigger char is itself a token but is not one of the + ;; closers (e.g. ?\; in Octave mode), so go back to the + ;; previous token. + (setq pos (point)) + (setq token (save-excursion + (funcall smie-backward-token-function)))) + (when (rassoc token smie-closer-alist) + ;; We're after a close token. Let's still make sure we + ;; didn't skip a comment to find that token. + (funcall smie-forward-token-function) + (when (and (save-excursion + ;; Trigger can be SPC, or reindent. + (skip-chars-forward " \n\t") + (>= (point) pos)) + ;; If token ends with a trigger char, so don't blink for + ;; anything else than this trigger char, lest we'd blink + ;; both when inserting the trigger char and when + ;; inserting a subsequent trigger char like SPC. + (or (eq (point) pos) + (not (memq (char-before) + smie-blink-matching-triggers))) + (or smie-blink-matching-inners + (null (nth 2 (assoc token smie-op-levels))))) + ;; The major mode might set blink-matching-check-function + ;; buffer-locally so that interactive calls to + ;; blink-matching-open work right, but let's not presume + ;; that's the case. + (let ((blink-matching-check-function #'smie-blink-matching-check)) + (blink-matching-open)))))))) ;;; The indentation engine. @@ -821,7 +856,7 @@ A nil offset for indentation after an opening token defaults to `smie-indent-basic'.") -(defun smie-indent-hanging-p () +(defun smie-indent--hanging-p () ;; A hanging keyword is one that's at the end of a line except it's not at ;; the beginning of a line. (and (save-excursion @@ -830,19 +865,19 @@ (forward-char 1)) (skip-chars-forward " \t") (eolp)) - (not (smie-bolp)))) + (not (smie-indent--bolp)))) -(defun smie-bolp () +(defun smie-indent--bolp () (save-excursion (skip-chars-backward " \t") (bolp))) -(defun smie-indent-offset (elem) +(defun smie-indent--offset (elem) (or (cdr (assq elem smie-indent-rules)) (cdr (assq t smie-indent-rules)) smie-indent-basic)) (defvar smie-indent-debug-log) -(defun smie-indent-offset-rule (tokinfo &optional after parent) +(defun smie-indent--offset-rule (tokinfo &optional after parent) "Apply the OFFSET-RULES in TOKINFO. Point is expected to be right in front of the token corresponding to TOKINFO. If computing the indentation after the token, then AFTER is the position @@ -857,10 +892,10 @@ ((not (consp rule)) (setq offset rule)) ((eq (car rule) '+) (setq offset rule)) ((eq (car rule) :hanging) - (when (smie-indent-hanging-p) + (when (smie-indent--hanging-p) (setq rules (cdr rule)))) ((eq (car rule) :bolp) - (when (smie-bolp) + (when (smie-indent--bolp) (setq rules (cdr rule)))) ((eq (car rule) :eolp) (unless after @@ -900,13 +935,13 @@ (push (list (point) offset tokinfo) smie-indent-debug-log)) offset)) -(defun smie-indent-column (offset &optional base parent virtual-point) +(defun smie-indent--column (offset &optional base parent virtual-point) "Compute the actual column to use for a given OFFSET. BASE is the base position to use, and PARENT is the parent info, if any. If VIRTUAL-POINT is non-nil, then `point' is virtual." (cond ((eq (car-safe offset) '+) - (apply '+ (mapcar (lambda (offset) (smie-indent-column offset nil parent)) + (apply '+ (mapcar (lambda (offset) (smie-indent--column offset nil parent)) (cdr offset)))) ((integerp offset) (+ offset @@ -941,7 +976,7 @@ (smie-indent-virtual)) ((eq offset nil) nil) ((and (symbolp offset) (boundp 'offset)) - (smie-indent-column (symbol-value offset) base parent virtual-point)) + (smie-indent--column (symbol-value offset) base parent virtual-point)) (t (error "Unknown indentation offset %s" offset)))) (defun smie-indent-forward-token () @@ -974,11 +1009,11 @@ need to compute the column at which point should be indented in order to figure out the indentation of some other (further down) point." ;; Trust pre-existing indentation on other lines. - (if (smie-bolp) (current-column) (smie-indent-calculate))) + (if (smie-indent--bolp) (current-column) (smie-indent-calculate))) (defun smie-indent-fixindent () ;; Obey the `fixindent' special comment. - (and (smie-bolp) + (and (smie-indent--bolp) (save-excursion (comment-normalize-vars) (re-search-forward (concat comment-start-skip @@ -1018,14 +1053,14 @@ (save-excursion (goto-char pos) ;; Different cases: - ;; - smie-bolp: "indent according to others". + ;; - smie-indent--bolp: "indent according to others". ;; - common hanging: "indent according to others". ;; - SML-let hanging: "indent like parent". ;; - if-after-else: "indent-like parent". ;; - middle-of-line: "trust current position". (cond ((null (cdr toklevels)) nil) ;Not a keyword. - ((smie-bolp) + ((smie-indent--bolp) ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). nil) @@ -1037,8 +1072,8 @@ ;; By default use point unless we're hanging. `((:before . ,token) (:hanging nil) point))) ;; (after (prog1 (point) (goto-char pos))) - (offset (smie-indent-offset-rule tokinfo))) - (smie-indent-column offset))))) + (offset (smie-indent--offset-rule tokinfo))) + (smie-indent--column offset))))) ;; FIXME: This still looks too much like black magic!! ;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we @@ -1054,7 +1089,7 @@ point))) (offset (save-excursion (goto-char pos) - (smie-indent-offset-rule tokinfo nil parent)))) + (smie-indent--offset-rule tokinfo nil parent)))) ;; Different behaviors: ;; - align with parent. ;; - parent + offset. @@ -1079,10 +1114,10 @@ nil) ((eq (car parent) (car toklevels)) ;; We bumped into a same-level operator. align with it. - (if (and (smie-bolp) (/= (point) pos) + (if (and (smie-indent--bolp) (/= (point) pos) (save-excursion (goto-char (goto-char (cadr parent))) - (not (smie-bolp))) + (not (smie-indent--bolp))) ;; Check the offset of `token' rather then its parent ;; because its parent may have used a special rule. E.g. ;; function foo; @@ -1119,7 +1154,7 @@ ;; So as to align with the earliest appropriate place. (smie-indent-virtual))) (tokinfo - (if (and (= (point) pos) (smie-bolp) + (if (and (= (point) pos) (smie-indent--bolp) (or (eq offset 'point) (and (consp offset) (memq 'point offset)))) ;; Since we started at BOL, we're not computing a virtual @@ -1127,7 +1162,7 @@ ;; we can't use `current-column' which would cause ;; indentation to depend on itself. nil - (smie-indent-column offset 'parent parent + (smie-indent--column offset 'parent parent ;; If we're still at pos, indent-virtual ;; will inf-loop. (unless (= (point) pos) 'virtual)))))))))) @@ -1137,8 +1172,12 @@ ;; Don't do it for virtual indentations. We should normally never be "in ;; front of a comment" when doing virtual-indentation anyway. And if we are ;; (as can happen in octave-mode), moving forward can lead to inf-loops. - (and (smie-bolp) - (looking-at comment-start-skip) + (and (smie-indent--bolp) + (let ((pos (point))) + (save-excursion + (beginning-of-line) + (and (re-search-forward comment-start-skip (line-end-position) t) + (eq pos (or (match-end 1) (match-beginning 0)))))) (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") @@ -1159,6 +1198,20 @@ (if (looking-at (regexp-quote continue)) (current-column)))))))) +(defun smie-indent-comment-close () + (and (boundp 'comment-end-skip) + comment-end-skip + (not (looking-at " \t*$")) ;Not just a \n comment-closer. + (looking-at comment-end-skip) + (nth 4 (syntax-ppss)) + (save-excursion + (goto-char (nth 8 (syntax-ppss))) + (current-column)))) + +(defun smie-indent-comment-inside () + (and (nth 4 (syntax-ppss)) + 'noindent)) + (defun smie-indent-after-keyword () ;; Indentation right after a special keyword. (save-excursion @@ -1178,13 +1231,13 @@ ;; Using the BNF syntax, we could come up with better ;; defaults, but we only have the precedence levels here. (setq tokinfo (list tok 'default-rule - (if (cadr toklevel) 0 (smie-indent-offset t))))) + (if (cadr toklevel) 0 (smie-indent--offset t))))) (let ((offset - (or (smie-indent-offset-rule tokinfo pos) - (smie-indent-offset t)))) + (or (smie-indent--offset-rule tokinfo pos) + (smie-indent--offset t)))) (let ((before (point))) (goto-char pos) - (smie-indent-column offset before))))))) + (smie-indent--column offset before))))))) (defun smie-indent-exps () ;; Indentation of sequences of simple expressions without @@ -1207,7 +1260,7 @@ arg) (while (and (null (car (smie-backward-sexp))) (push (point) positions) - (not (smie-bolp)))) + (not (smie-indent--bolp)))) (save-excursion ;; Figure out if the atom we just skipped is an argument rather ;; than a function. @@ -1232,17 +1285,18 @@ (positions ;; We're the first arg. (goto-char (car positions)) - ;; FIXME: Use smie-indent-column. - (+ (smie-indent-offset 'args) + ;; FIXME: Use smie-indent--column. + (+ (smie-indent--offset 'args) ;; We used to use (smie-indent-virtual), but that ;; doesn't seem right since it might then indent args less than ;; the function itself. (current-column))))))) (defvar smie-indent-functions - '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment - smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword - smie-indent-exps) + '(smie-indent-fixindent smie-indent-bob smie-indent-close + smie-indent-comment smie-indent-comment-continue smie-indent-comment-close + smie-indent-comment-inside smie-indent-keyword smie-indent-after-keyword + smie-indent-exps) "Functions to compute the indentation. Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column
--- a/lisp/emacs-lisp/syntax.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/syntax.el Wed Sep 22 15:46:51 2010 +0900 @@ -34,7 +34,6 @@ ;; - do something about the case where the syntax-table is changed. ;; This typically happens with tex-mode and its `$' operator. -;; - move font-lock-syntactic-keywords in here. Then again, maybe not. ;; - new functions `syntax-state', ... to replace uses of parse-partial-state ;; with something higher-level (similar to syntax-ppss-context). ;; - interaction with mmm-mode. @@ -47,6 +46,281 @@ (defvar font-lock-beginning-of-syntax-function) +;;; Applying syntax-table properties where needed. + +(defvar syntax-propertize-function nil + ;; Rather than a -functions hook, this is a -function because it's easier + ;; to do a single scan than several scans: with multiple scans, one cannot + ;; assume that the text before point has been propertized, so syntax-ppss + ;; gives unreliable results (and stores them in its cache to boot, so we'd + ;; have to flush that cache between each function, and we couldn't use + ;; syntax-ppss-flush-cache since that would not only flush the cache but also + ;; reset syntax-propertize--done which should not be done in this case). + "Mode-specific function to apply the syntax-table properties. +Called with 2 arguments: START and END. +This function can call `syntax-ppss' on any position before END, but it +should not call `syntax-ppss-flush-cache', which means that it should not +call `syntax-ppss' on some position and later modify the buffer on some +earlier position.") + +(defvar syntax-propertize-chunk-size 500) + +(defvar syntax-propertize-extend-region-functions + '(syntax-propertize-wholelines) + "Special hook run just before proceeding to propertize a region. +This is used to allow major modes to help `syntax-propertize' find safe buffer +positions as beginning and end of the propertized region. Its most common use +is to solve the problem of /identification/ of multiline elements by providing +a function that tries to find such elements and move the boundaries such that +they do not fall in the middle of one. +Each function is called with two arguments (START and END) and it should return +either a cons (NEW-START . NEW-END) or nil if no adjustment should be made. +These functions are run in turn repeatedly until they all return nil. +Put first the functions more likely to cause a change and cheaper to compute.") +;; Mark it as a special hook which doesn't use any global setting +;; (i.e. doesn't obey the element t in the buffer-local value). +(make-variable-buffer-local 'syntax-propertize-extend-region-functions) + +(defun syntax-propertize-wholelines (start end) + (goto-char start) + (cons (line-beginning-position) + (progn (goto-char end) + (if (bolp) (point) (line-beginning-position 2))))) + +(defun syntax-propertize-multiline (beg end) + "Let `syntax-propertize' pay attention to the syntax-multiline property." + (when (and (> beg (point-min)) + (get-text-property (1- beg) 'syntax-multiline)) + (setq beg (or (previous-single-property-change beg 'syntax-multiline) + (point-min)))) + ;; + (when (get-text-property end 'font-lock-multiline) + (setq end (or (text-property-any end (point-max) + 'syntax-multiline nil) + (point-max)))) + (cons beg end)) + +(defvar syntax-propertize--done -1 + "Position upto which syntax-table properties have been set.") +(make-variable-buffer-local 'syntax-propertize--done) + +(defun syntax-propertize--shift-groups (re n) + (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + +(defmacro syntax-propertize-precompile-rules (&rest rules) + "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. +The arg RULES can be of the same form as in `syntax-propertize-rules'. +The return value is an object that can be passed as a rule to +`syntax-propertize-rules'. +I.e. this is useful only when you want to share rules among several +syntax-propertize-functions." + (declare (debug syntax-propertize-rules)) + ;; Precompile? Yeah, right! + ;; Seriously, tho, this is a macro for 2 reasons: + ;; - we could indeed do some pre-compilation at some point in the future, + ;; e.g. fi/when we switch to a DFA-based implementation of + ;; syntax-propertize-rules. + ;; - this lets Edebug properly annotate the expressions inside RULES. + `',rules) + +(defmacro syntax-propertize-rules (&rest rules) + "Make a function that applies RULES for use in `syntax-propertize-function'. +The function will scan the buffer, applying the rules where they match. +The buffer is scanned a single time, like \"lex\" would, rather than once +per rule. + +Each RULE can be a symbol, in which case that symbol's value should be, +at macro-expansion time, a precompiled set of rules, as returned +by `syntax-propertize-precompile-rules'. + +Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where +REGEXP is an expression (evaluated at time of macro-expansion) that returns +a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to +apply the property SYNTAX to the chars matched by the subgroup NUMBER +of the regular expression, if NUMBER did match. +SYNTAX is an expression that returns a value to apply as `syntax-table' +property. Some expressions are handled specially: +- if SYNTAX is a string, then it is converted with `string-to-syntax'; +- if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP + will be applied to the buffer before running EXPS and if EXP is a string it + is also converted with `string-to-syntax'. +The SYNTAX expression is responsible to save the `match-data' if needed +for subsequent HIGHLIGHTs. +Also SYNTAX is free to move point, in which case RULES may not be applied to +some parts of the text or may be applied several times to other parts. + +Note: back-references in REGEXPs do not work." + (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. + (form &rest + (numberp + [&or stringp ;FIXME: Use &wrap + ("prog1" [&or stringp def-form] def-body) + def-form]))))) + (let ((newrules nil)) + (while rules + (if (symbolp (car rules)) + (setq rules (append (symbol-value (pop rules)) rules)) + (push (pop rules) newrules))) + (setq rules (nreverse newrules))) + (let* ((offset 0) + (branches '()) + ;; We'd like to use a real DFA-based lexer, usually, but since Emacs + ;; doesn't have one yet, we fallback on building one large regexp + ;; and use groups to determine which branch of the regexp matched. + (re + (mapconcat + (lambda (rule) + (let* ((orig-re (eval (car rule))) + (re orig-re)) + (when (and (assq 0 rule) (cdr rules)) + ;; If there's more than 1 rule, and the rule want to apply + ;; highlight to match 0, create an extra group to be able to + ;; tell when *this* match 0 has succeeded. + (incf offset) + (setq re (concat "\\(" re "\\)"))) + (setq re (syntax-propertize--shift-groups re offset)) + (let ((code '()) + (condition + (cond + ((assq 0 rule) (if (zerop offset) t + `(match-beginning ,offset))) + ((null (cddr rule)) + `(match-beginning ,(+ offset (car (cadr rule))))) + (t + `(or ,@(mapcar + (lambda (case) + `(match-beginning ,(+ offset (car case)))) + (cdr rule)))))) + (nocode t) + (offset offset)) + ;; If some of the subgroup rules include Elisp code, then we + ;; need to set the match-data so it's consistent with what the + ;; code expects. If not, then we can simply use shifted + ;; offset in our own code. + (unless (zerop offset) + (dolist (case (cdr rule)) + (unless (stringp (cadr case)) + (setq nocode nil))) + (unless nocode + (push `(let ((md (match-data 'ints))) + ;; Keep match 0 as is, but shift everything else. + (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md)) + (set-match-data md)) + code) + (setq offset 0))) + ;; Now construct the code for each subgroup rules. + (dolist (case (cdr rule)) + (assert (null (cddr case))) + (let* ((gn (+ offset (car case))) + (action (nth 1 case)) + (thiscode + (cond + ((stringp action) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax action)))) + ((eq (car-safe action) 'ignore) + (cdr action)) + ((eq (car-safe action) 'prog1) + (if (stringp (nth 1 action)) + `((put-text-property + (match-beginning ,gn) (match-end ,gn) + 'syntax-table + ',(string-to-syntax (nth 1 action))) + ,@(nthcdr 2 action)) + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,(nth 1 action))) + (if syntax + (put-text-property + mb me 'syntax-table syntax)) + ,@(nthcdr 2 action))))) + (t + `((let ((mb (match-beginning ,gn)) + (me (match-end ,gn)) + (syntax ,action)) + (if syntax + (put-text-property + mb me 'syntax-table syntax)))))))) + + (if (or (not (cddr rule)) (zerop gn)) + (setq code (nconc (nreverse thiscode) code)) + (push `(if (match-beginning ,gn) + ;; Try and generate clean code with no + ;; extraneous progn. + ,(if (null (cdr thiscode)) + (car thiscode) + `(progn ,@thiscode))) + code)))) + (push (cons condition (nreverse code)) + branches)) + (incf offset (regexp-opt-depth orig-re)) + re)) + rules + "\\|"))) + `(lambda (start end) + (goto-char start) + (while (and (< (point) end) + (re-search-forward ,re end t)) + (cond ,@(nreverse branches)))))) + +(defun syntax-propertize-via-font-lock (keywords) + "Propertize for syntax in START..END using font-lock syntax. +KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. +The return value is a function suitable for `syntax-propertize-function'." + (lexical-let ((keywords keywords)) + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords)))))) + +(defun syntax-propertize (pos) + "Ensure that syntax-table properties are set upto POS." + (when (and syntax-propertize-function + (< syntax-propertize--done pos)) + ;; (message "Needs to syntax-propertize from %s to %s" + ;; syntax-propertize--done pos) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (save-excursion + (with-silent-modifications + (let* ((start (max syntax-propertize--done (point-min))) + (end (max pos + (min (point-max) + (+ start syntax-propertize-chunk-size)))) + (funs syntax-propertize-extend-region-functions)) + (while funs + (let ((new (funcall (pop funs) start end))) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless (eq funs + (cdr syntax-propertize-extend-region-functions)) + (setq funs syntax-propertize-extend-region-functions))))) + ;; Move the limit before calling the function, so the function + ;; can use syntax-ppss. + (setq syntax-propertize--done end) + ;; (message "syntax-propertizing from %s to %s" start end) + (remove-text-properties start end + '(syntax-table nil syntax-multiline nil)) + (funcall syntax-propertize-function start end)))))) + +;;; Incrementally compute and memoize parser state. + (defsubst syntax-ppss-depth (ppss) (nth 0 ppss)) @@ -92,6 +366,8 @@ (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." + ;; Set syntax-propertize to refontify anything past beg. + (setq syntax-propertize--done (min beg syntax-propertize--done)) ;; Flush invalid cache entries. (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg)) (setq syntax-ppss-cache (cdr syntax-ppss-cache))) @@ -128,6 +404,7 @@ Point is at POS when this function returns." ;; Default values. (unless pos (setq pos (point))) + (syntax-propertize pos) ;; (let ((old-ppss (cdr syntax-ppss-last)) (old-pos (car syntax-ppss-last))
--- a/lisp/emacs-lisp/warnings.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/emacs-lisp/warnings.el Wed Sep 22 15:46:51 2010 +0900 @@ -119,9 +119,9 @@ :type '(repeat (repeat symbol)) :version "22.1") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-prefix-function nil "Function to generate warning prefixes. @@ -132,9 +132,9 @@ and the function can insert text in it. This text becomes the beginning of the warning.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-series nil "Non-nil means treat multiple `display-warning' calls as a series. @@ -146,16 +146,16 @@ also call that function before the next warning.") (put 'warning-series 'risky-local-variable t) -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-fill-prefix nil "Non-nil means fill each warning text using this string as `fill-prefix'.") -;;; The autoload cookie is so that programs can bind this variable -;;; safely, testing the existing value, before they call one of the -;;; warnings functions. +;; The autoload cookie is so that programs can bind this variable +;; safely, testing the existing value, before they call one of the +;; warnings functions. ;;;###autoload (defvar warning-type-format (purecopy " (%s)") "Format for displaying the warning type in the warning message. @@ -241,6 +241,8 @@ (with-current-buffer buffer ;; If we created the buffer, disable undo. (unless old + (special-mode) + (setq buffer-read-only t) (setq buffer-undo-list t)) (goto-char (point-max)) (when (and warning-series (symbolp warning-series)) @@ -248,6 +250,7 @@ (prog1 (point-marker) (unless (eq warning-series t) (funcall warning-series))))) + (let ((inhibit-read-only t)) (unless (bolp) (newline)) (setq start (point)) @@ -262,7 +265,7 @@ (let ((fill-prefix warning-fill-prefix) (fill-column 78)) (fill-region start (point)))) - (setq end (point)) + (setq end (point))) (when (and (markerp warning-series) (eq (marker-buffer warning-series) buffer)) (goto-char warning-series)))
--- a/lisp/epa-file.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/epa-file.el Wed Sep 22 15:46:51 2010 +0900 @@ -158,12 +158,17 @@ (if (or beg end) (setq string (substring string (or beg 0) end))) (save-excursion - (save-restriction - (narrow-to-region (point) (point)) - (epa-file-decode-and-insert string file visit beg end replace) - (setq length (- (point-max) (point-min)))) - (if replace - (delete-region (point) (point-max))) + ;; If visiting, bind off buffer-file-name so that + ;; file-locking will not ask whether we should + ;; really edit the buffer. + (let ((buffer-file-name + (if visit nil buffer-file-name))) + (save-restriction + (narrow-to-region (point) (point)) + (epa-file-decode-and-insert string file visit beg end replace) + (setq length (- (point-max) (point-min)))) + (if replace + (delete-region (point) (point-max)))) (if visit (set-visited-file-modtime)))) (if (and local-copy
--- a/lisp/font-lock.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/font-lock.el Wed Sep 22 15:46:51 2010 +0900 @@ -544,6 +544,8 @@ contexts will not be affected. This is normally set via `font-lock-defaults'.") +(make-obsolete-variable 'font-lock-syntactic-keywords + 'syntax-propertize-function "24.1") (defvar font-lock-syntax-table nil "Non-nil means use this syntax table for fontifying. @@ -562,6 +564,8 @@ we recommend setting `syntax-begin-function' instead. This is normally set via `font-lock-defaults'.") +(make-obsolete-variable 'font-lock-beginning-of-syntax-function + 'syntax-begin-function "23.3") (defvar font-lock-mark-block-function nil "*Non-nil means use this function to mark a block of text. @@ -612,11 +616,10 @@ ;; ;; Borrowed from lazy-lock.el. ;; We use this to preserve or protect things when modifying text properties. - (defmacro save-buffer-state (varlist &rest body) + (defmacro save-buffer-state (&rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." - (declare (indent 1) (debug let)) - `(let* ,(append varlist - `((inhibit-point-motion-hooks t))) + (declare (indent 0) (debug t)) + `(let ((inhibit-point-motion-hooks t)) (with-silent-modifications ,@body))) ;; @@ -1020,7 +1023,7 @@ (funcall font-lock-fontify-region-function beg end loudly)) (defun font-lock-unfontify-region (beg end) - (save-buffer-state nil + (save-buffer-state (funcall font-lock-unfontify-region-function beg end))) (defun font-lock-default-fontify-buffer () @@ -1113,8 +1116,6 @@ (defun font-lock-default-fontify-region (beg end loudly) (save-buffer-state - ((parse-sexp-lookup-properties - (or parse-sexp-lookup-properties font-lock-syntactic-keywords))) ;; Use the fontification syntax table, if any. (with-syntax-table (or font-lock-syntax-table (syntax-table)) (save-restriction @@ -1136,8 +1137,14 @@ (setq beg font-lock-beg end font-lock-end)) ;; Now do the fontification. (font-lock-unfontify-region beg end) - (when font-lock-syntactic-keywords - (font-lock-fontify-syntactic-keywords-region beg end)) + (when (and font-lock-syntactic-keywords + (null syntax-propertize-function)) + ;; Ensure the beginning of the file is properly syntactic-fontified. + (let ((start beg)) + (when (< font-lock-syntactically-fontified start) + (setq start (max font-lock-syntactically-fontified (point-min))) + (setq font-lock-syntactically-fontified end)) + (font-lock-fontify-syntactic-keywords-region start end))) (unless font-lock-keywords-only (font-lock-fontify-syntactically-region beg end loudly)) (font-lock-fontify-keywords-region beg end loudly))))) @@ -1436,11 +1443,10 @@ (defun font-lock-fontify-syntactic-keywords-region (start end) "Fontify according to `font-lock-syntactic-keywords' between START and END. START should be at the beginning of a line." - ;; Ensure the beginning of the file is properly syntactic-fontified. - (when (and font-lock-syntactically-fontified - (< font-lock-syntactically-fontified start)) - (setq start (max font-lock-syntactically-fontified (point-min))) - (setq font-lock-syntactically-fontified end)) + (unless parse-sexp-lookup-properties + ;; We wouldn't go through so much trouble if we didn't intend to use those + ;; properties, would we? + (set (make-local-variable 'parse-sexp-lookup-properties) t)) ;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords. (when (symbolp font-lock-syntactic-keywords) (setq font-lock-syntactic-keywords (font-lock-eval-keywords @@ -1483,19 +1489,18 @@ (defvar font-lock-comment-end-skip nil "If non-nil, Font Lock mode uses this instead of `comment-end'.") -(defun font-lock-fontify-syntactically-region (start end &optional loudly ppss) +(defun font-lock-fontify-syntactically-region (start end &optional loudly) "Put proper face on each string and comment between START and END. START should be at the beginning of a line." + (syntax-propertize end) ; Apply any needed syntax-table properties. (let ((comment-end-regexp (or font-lock-comment-end-skip (regexp-quote (replace-regexp-in-string "^ *" "" comment-end)))) - state face beg) + ;; Find the `start' state. + (state (syntax-ppss start)) + face beg) (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) - (goto-char start) - ;; - ;; Find the `start' state. - (setq state (or ppss (syntax-ppss start))) ;; ;; Find each interesting place between here and `end'. (while
--- a/lisp/frame.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/frame.el Wed Sep 22 15:46:51 2010 +0900 @@ -907,15 +907,16 @@ (t (suspend-emacs))))) (defun make-frame-names-alist () + ;; Only consider the frames on the same display. (let* ((current-frame (selected-frame)) (falist (cons (cons (frame-parameter current-frame 'name) current-frame) nil)) - (frame (next-frame nil t))) + (frame (next-frame nil 0))) (while (not (eq frame current-frame)) (progn - (setq falist (cons (cons (frame-parameter frame 'name) frame) falist)) - (setq frame (next-frame frame t)))) + (push (cons (frame-parameter frame 'name) frame) falist) + (setq frame (next-frame frame 0)))) falist)) (defvar frame-name-history nil)
--- a/lisp/fringe.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/fringe.el Wed Sep 22 15:46:51 2010 +0900 @@ -136,6 +136,14 @@ ;; Otherwise impose the user-specified value of fringe-mode. (custom-initialize-reset symbol value)))) +(defconst fringe-styles + '(("default" . nil) + ("no-fringes" . 0) + ("right-only" . (0 . nil)) + ("left-only" . (nil . 0)) + ("half-width" . (4 . 4)) + ("minimal" . (1 . 1)))) + (defcustom fringe-mode nil "Specify appearance of fringes on all frames. This variable can be nil (the default) meaning the fringes should have @@ -144,21 +152,27 @@ a cons cell where car indicates width of left fringe and cdr indicates width of right fringe (where again 0 can be used to indicate no fringe). +Note that the actual width may be rounded up to ensure that the sum of +the width of the left and right fringes is a multiple of the frame's +character width. However, a fringe width of 0 is never rounded. To set this variable in a Lisp program, use `set-fringe-mode' to make it take real effect. Setting the variable with a customization buffer also takes effect. If you only want to modify the appearance of the fringe in one frame, you can use the interactive function `set-fringe-style'." - :type '(choice (const :tag "Default width" nil) - (const :tag "No fringes" 0) - (const :tag "Only right" (0 . nil)) - (const :tag "Only left" (nil . 0)) - (const :tag "Half width" (5 . 5)) - (const :tag "Minimal" (1 . 1)) - (integer :tag "Specific width") - (cons :tag "Different left/right sizes" - (integer :tag "Left width") - (integer :tag "Right width"))) + :type `(choice + ,@ (mapcar (lambda (style) + (let ((name + (replace-regexp-in-string "-" " " (car style)))) + `(const :tag + ,(concat (capitalize (substring name 0 1)) + (substring name 1)) + ,(cdr style)))) + fringe-styles) + (integer :tag "Specific width") + (cons :tag "Different left/right sizes" + (integer :tag "Left width") + (integer :tag "Right width"))) :group 'fringe :require 'fringe :initialize 'fringe-mode-initialize @@ -175,27 +189,20 @@ `default-frame-alist' is used when user enters the empty string. Otherwise the negation of the fringe value in the currently selected frame parameter is used." - (let ((mode (intern (completing-read - (concat - "Select fringe mode for " - (if all-frames "all frames" "selected frame") - " (type ? for list): ") - '(("none") ("default") ("left-only") - ("right-only") ("half") ("minimal")) - nil t)))) - (cond ((eq mode 'none) 0) - ((eq mode 'default) nil) - ((eq mode 'left-only) '(nil . 0)) - ((eq mode 'right-only) '(0 . nil)) - ((eq mode 'half) '(5 . 5)) - ((eq mode 'minimal) '(1 . 1)) - ((eq mode (intern "")) - (if (eq 0 (cdr (assq 'left-fringe - (if all-frames - default-frame-alist - (frame-parameters (selected-frame)))))) - nil - 0))))) + (let* ((mode (completing-read + (concat + "Select fringe mode for " + (if all-frames "all frames" "selected frame") + " (type ? for list): ") + fringe-styles nil t)) + (style (assoc (downcase mode) fringe-styles))) + (if style (cdr style) + (if (eq 0 (cdr (assq 'left-fringe + (if all-frames + default-frame-alist + (frame-parameters (selected-frame)))))) + nil + 0)))) (defun fringe-mode (&optional mode) "Set the default appearance of fringes on all frames.
--- a/lisp/gnus/.dir-locals.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/.dir-locals.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,1 +1,4 @@ ((emacs-lisp-mode . ((show-trailing-whitespace . t)))) +;; Local Variables: +;; no-byte-compile: t +;; End:
--- a/lisp/gnus/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,509 @@ +2010-09-21 Adam Sjøgren <asjo@koldfront.dk> + + * gnus-sum.el (gnus-adjust-marked-articles): Fix typo. + +2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-int.el (gnus-open-server): Give a better error message in the + "go offline" case. + + * gnus-sum.el (gnus-adjust-marked-articles): Hack to avoid adjusting + marks for nnimap, which is seldom the right thing to do. + + * gnus.el (gnus-sloppily-equal-method-parameters): Refactor out. + (gnus-same-method-different-name): New function. + + * nnimap.el (parse-time): Require. + + * gnus-start.el (gnus-get-unread-articles): Fix the prefixed select + method in the presence of many similar methods. + + * nnmail.el (nnmail-expired-article-p): Fix typo: time-subtract. + + * nnimap.el (nnimap-find-expired-articles): Don't refer to + nnml-inhibit-expiry. + + * gnus-sum.el (gnus-summary-move-article): Use gnus-server-equal to + find out whether methods are equal. + + * nnimap.el (nnimap-find-expired-articles): New function. + (nnimap-process-expiry-targets): New function. + (nnimap-request-move-article): Request the article before looking at + what the Message-ID is. Fix found by Andrew Cohen. + (nnimap-mark-and-expunge-incoming): Wait for the last sequence. + + * nnmail.el (nnmail-expired-article-p): Allow returning the cutoff time + for oldness in addition to being a predicate. + + * nnimap.el (nnimap-request-group): When we have zero articles, return + the right data to Gnus. + (nnimap-request-expire-articles): Only delete articles immediately if + the target is 'delete. + + * gnus-sum.el (gnus-summary-move-article): When respooling to the same + method, this would bug out. + + * gnus-group.el (gnus-group-expunge-group): Renamed from + gnus-group-nnimap-expunge, and implemented as a normal interface + function. + + * gnus-int.el (gnus-request-expunge-group): New function. + + * nnimap.el (nnimap-request-create-group): Implement. + (nnimap-request-expunge-group): New function. + +2010-09-21 Julien Danjou <julien@danjou.info> + + * gnus-html.el (gnus-html-image-cache-ttl): Add new variable. + (gnus-html-cache-expired): Add new function. + (gnus-html-wash-images): Use `gnus-html-cache-expired' to check + wethever we should display image for fetch it. + Compute alt-text earlier to pass it to the fetching function too. + (gnus-html-schedule-image-fetching): Change function argument to only + get one image at a time, not a list. + (gnus-html-image-fetched): Use `url-store-in-cache' to store image in + cache. + (gnus-html-get-image-data): New function to retrieve image data from + cache. + (gnus-html-put-image): Change buffer argument to use image data rather + than file, and place image above region rather than inserting a new + one. Do not take alt-text as argument, since it's useless now: we place + the image above alt-text. + (gnus-html-prune-cache): Remove. + (gnus-html-show-images): Start to fetch image when we find one, do not + push into a temporary list. + (gnus-html-prefetch-images): Only fetch image if they have expired. + (gnus-html-browse-image): Fix, use 'gnus-image-url. + (gnus-html-image-map): Add "v" to browse-url on undisplayed image. + +2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-parameter): Doc fix. + +2010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-request-group): Don't select the imap buffer before + opening the server. + (nnimap-request-delete-group): Implement group deletion. + (nnimap-transform-headers): Return the size of the entire message in + the Bytes header, not just the size of the first part. + (nnimap-request-move-article): When moving an article from nnimap, + request the article first so the accepting form has an article to + accept. Reported by Dan Christensen. + (nnimap-command): Make sure that the error message doesn't error out. + +2010-09-20 David Edmondson <dme@dme.org> (tiny change) + + * nnimap.el (nnimap-request-set-mark): Don't wait for a response when + we haven't requested anything. + +2010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-fetch-inbox): Use "[]" as the parameter instead of + "". Fix found by Andrew Cohen. + + * mail-parse.el (mail-header-encode-parameter): Use -encode-parameter + instead of -encode-string. + +2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-html-image-fetched): Pass arg to kill-buffer. + + * gnus-sum.el (gnus-summary-update-mark): Replace subst-char-in-string + by mm-subst-char-in-string. + +2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-wait-for-connection): Avoid a race condition while + waiting for the connection string. + + * gnus-html.el (gnus-html-image-fetched): Protect against the data not + arriving. + + * gnus-start.el (gnus-ignored-newsgroups): Remove [] from the list of + bogus characters. This allows selecting certain Gmail groups. + + * nnimap.el (nnimap-find-wanted-parts-1): New function. + (nnimap-fetch-partial-articles): New variable. + (nnimap-open-connection): When looking for credentials, also use the + nnimap-server-port. + (nnimap-request-article): Return the group/article number, so that Gnus + `^' works as expected. + (nnimap-find-wanted-parts-1): Return the MIME parts as IMAP wants + them. + + * gnus.el (gnus-similar-server-opened): Refactor a bit and add + comments. + (gnus-methods-sloppily-equal): New function. + (gnus): When using the development version of Gnus, load the gnus-load + file. + + * gnus-start.el (gnus-get-unread-articles): Make sure that we call + `gnus-open-server' on each method before trying to scan them etc. This + ensures that all the backend parameters are set correctly. + + * nnimap.el (nnimap-authenticator): New variable. + (nnimap-open-connection): Allow anonymous login. + (nnimap-transform-headers): The chars header is called Chars not + Bytes. + (nnimap-wait-for-response): Don't infloop if the IMAP connection + drops. + + * gnus-art.el (gnus-article-describe-briefly): Fix up typo in last + patch, found by Knut Anders Hatlen. + +2010-09-19 Andreas Schwab <schwab@linux-m68k.org> + + * gnus-agent.el (gnus-agent-batch-confirmation) + (gnus-agent-expire-group, gnus-agent-expire): Pass proper format string + to gnus-message. + * gnus-art.el (gnus-article-describe-briefly): Likewise. + * gnus-group.el (gnus-group-list-groups, gnus-group-describe-group) + (gnus-group-edit-global-kill, gnus-group-describe-briefly): Likewise. + * gnus-int.el (gnus-open-server): Likewise. + * gnus-score.el (gnus-score-edit-current-scores, gnus-score-edit-file) + (gnus-score-check-syntax): Likewise. + * gnus-srvr.el (gnus-browse-describe-briefly): Likewise. + * gnus-start.el (gnus-read-active-file-1, gnus-read-active-file-1): + Likewise. + * gnus-sum.el (gnus-summary-describe-briefly): Likewise. + +2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-prefetch-images): Fix up the url-retrieve + calling conventions so that prefetch doesn't bug out. + +2010-09-19 Julien Danjou <julien@danjou.info> + + * gnus-sum.el (gnus-summary-update-mark): Use `subst-char-in-string' + rather than `subst-char-in-region' in order to be able to replace ASCII + char by UTF-8 ones. + + * gnus-html.el (gnus-html-prefetch-images): Use `url-retrieve' rather + than curl. + (gnus-html-image-fetched): Fix `gnus-html-put-image' call not setting + the right URL and ALT text on images. + (gnus-html-wash-tags): Fix tag case. + Add support for `s' and `ins' tags. Use gnus-emphasis-* faces. + (gnus-article-html): Add -o display_ins_del=2 option. + (gnus-html-wash-tags): Add better support for <ul> tags symbols. + +2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnheader.el (nnheader-insert-nov): Protect against junk appearing in + the extra mail headers, which sometimes seem to happen for unknown + reasons. + + * mail-parse.el (mail-header-encode-parameter): Define as + rfc2045-encode-string instead of as rfc2231-encode-string, since some + (or most, perhaps?) mail readers don't understand the latter, but do + understand the former. + + * gnus-agent.el (gnus-agent-auto-agentize-methods): Switch the default + to nil, so that no methods are automatically agentized. I think this + is probably what most users want. + + * gnus-html.el (gnus-html-schedule-image-fetching): Ignore all errors + from url-retrieve, for instance about invalid URLs. + + * nnimap.el (nnimap-finish-retrieve-group-infos): Protect against + groups that have no articles. + (nnimap-request-article): Check that we really got an article when we + requested one. + + * gnus-agent.el (gnus-agent-load-alist): Nix out the alist if the file + doesn't exist. + + * nnimap.el (nnimap-finish-retrieve-group-infos): Return data in the + nntp buffer so the agent can save it. + (nnimap-open-shell-stream): Bind `process-connection-type' to nil, so + that CRLF doesn't get translated to \n. + (nnimap-open-connection): Don't make 'shell commands only send \n. + +2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * nnml.el (nnml-files): Add prefix to dynamic var `files'. + (nnml-generate-nov-databases-directory, nnml-generate-active-info): + Update var name. + (nnml-generate-nov-file): Use dolist. + (nnml-directory-articles, nnml-current-group-article-to-file-alist): + Use with-current-buffer. + +2010-09-18 Julien Danjou <julien@danjou.info> + + * gnus-html.el (gnus-html-schedule-image-fetching): Fetch all images in + parallel. + +2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-update-info): When doing partial marks update, get + the range update right. + (nnimap-request-group): Don't make `M-g' bug out on group with no + marks. + (nnoo): Required, so that other packages can require nnimap. + (nnimap-wait-for-response): Be a bit more lax in finding the end of the + command we're looking for. This helps when the server sends more + responses after we've gotten everything we expected. + (nnimap): Add a `newlinep' field to keep track of end-of-line + conventions. + Don't send CRLF to things that don't want it. + (nnimap-request-accept-article): Ditto. + +2010-09-18 Julien Danjou <julien@danjou.info> + + * gnus-html.el (gnus-html-schedule-image-fetching): Use `url' rather + than curl to retrieve images. + +2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-update-info): Extend the info so that we can set + the marks. + (nnimap-open-connection): Fix typo -- should be 'shell, not 'stream. + (nnimap-wait-for-connection): New function. + (nnimap-open-connection): If we have PREAUTH, don't query for login + credentials. + (nnimap-update-info): Fix off-by-one error when concatenating ranges + when doing a partial update. + +2010-09-18 Julien Danjou <julien@danjou.info> + + * gnus-html.el (gnus-html-wash-tags): Add support for i, b and u HTML + tags. + +2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-credentials): New function. + (nnimap-open-connection): Use the new function to look for credentials + also on the numeric equivalents of "imap" and "imaps". + + * gnus-start.el (gnus-activate-group): Send the info to + gnus-request-group. + + * nnimap.el (nnimap-request-group): Have the "check" version of the + function parse flags and update the info, so that a `M-g' get a total + resync of all flags from the group. + + * gnus-int.el (gnus-request-group): Take an optional `info' parameter + to allow backends to alter the info on group selection. Also alter all + the backend -request-group functions to take the parameter. + + * nnimap.el (nnimap-store-info): New function. + (nnimap-update-info): Store the info for later usage. + (nnimap-request-group): Use the stored info for the dont-check case, so + that we don't retrieve all marks when we enter a group. + + * nnimap.el: Use deffoo instead of defun for interface functions. + + * gnus-start.el (gnus-get-unread-articles): Allow the backends to + update the group info. This makes the nndraft groups, for instance, go + back to their old behaviour. + + * gnus-sum.el (gnus-select-newsgroup): Indent. + + * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log + in. + (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for + nothing. + + * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups + from methods that are denied. + + * gnus-int.el (gnus-method-denied-p): New function. + + * nnimap.el (nnimap-open-connection): Use auth-sources to query and + store the password instead of netrc. + (nnimap-open-connection): Don't error out when we can't make a + connections. + + * auth-source.el (auth-source-create): In the password prompt, say what + we're querying for. Also prompt for user name if that hasn't been + given. + + * nnimap.el (nnimap-with-process-buffer): Removed. + +2010-09-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-read-active-for-groups): Don't use the "finish" + method when we're reading from the agent. + + * nnagent.el (nnagent-retrieve-group-data-early): New dummy method. + + * auth-source.el (auth-sources): Add ~/.authinfo to the default, since + that's probably most useful for users. + + * gnus-int.el (gnus-check-server): Save result so that it doesn't say + "failed" all the time. + + * gnus.el: Throughout all files, replace (save-excursion (set-buffer + ...)) with (with-current-buffer ... ). + + * nntp.el (nntp-open-server): Return whether the open was successful or + not. + + * gnus-sum.el (gnus-summary-first-subject): Have `unseen-or-unread' + select an unread unseen article first. + + * nnimap.el (nnimap-open-connection): If the user doesn't have a + /etc/services, supply some sensible port defaults. + + * dgnushack.el: Define netrc-credentials. + +2010-09-17 Julien Danjou <julien@danjou.info> (tiny fix) + + * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. + +2010-09-17 Knut Anders Hatlen <kahatlen@gmail.com> (tiny change) + + * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command + doesn't have any parameters. + +2010-09-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-open-connection): Upcase all capabilities, and use + only upcased checks. + + * nnmail.el (nnmail-article-group): Fix typo in "bogus" section. + + * nnimap.el (nnimap-open-shell-stream): New function. + (nnimap-open-connection): Use it. + (nnimap-transform-headers): Get the number of lines in each message. + (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the + number of lines. + (nnimap-request-list): Not all servers return UIDNEXT. Work past this + problem. + + * utf7.el (utf7-encode): Autoload. + + * nnmail.el (nnmail-inhibit-default-split-group): New internal variable + to allow the mail splitting to not return a default group. This is + useful for nnimap, which will leave unmatched mail in the inbox. + + * nnimap.el: Rewritten. + + * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for + nnimap usage. + + * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name + if the move is internal, so that nnimap can do fast internal moves. + + * gnus-start.el (gnus-get-unread-articles): Support early retrieval of + data. + (gnus-read-active-for-groups): Support finishing the early retrieval of + data. + + * gnus-range.el (gnus-range-nconcat): New function. + + * gnus-int.el (gnus-finish-retrieve-group-infos) + (gnus-retrieve-group-data-early): New functions. + +2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * nnrss.el (nnrss-retrieve-headers, nnrss-request-list-newsgroups) + (nnrss-retrieve-groups): + * pop3.el (pop3-open-server, pop3-read-response, pop3-list, pop3-retr) + (pop3-quit): Use with-current-buffer. + +2010-09-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * pop3.el (pop3-wait-for-messages): Use pop3-accept-process-output + instead of nnheader-accept-process-output. + + * gnus-html.el (gnus-html-schedule-image-fetching) + (gnus-html-prefetch-images): Replace process-kill-without-query by + gnus-set-process-query-on-exit-flag. + +2010-09-16 Romain Francoise <romain@orebokech.com> + + * gnus-html.el: Require gnus-art for `gnus-with-article-buffer'. + +2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-schedule-image-fetching) + (gnus-html-prefetch-images): Check for curl before using it. + + * mm-decode.el (mm-text-html-renderer): Don't have gnus-article-html + depend on curl, which isn't essential. + + * imap.el: Revert back to version + cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes + seem problematic. + +2010-09-14 Juanma Barranquero <lekktu@gmail.com> + + * gnus-registry.el (gnus-registry-install-shortcuts): + Explicitly pass `obarray' to `unintern' to avoid a warning. + +2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-read-active-for-groups): Reverted the previous + change. + + * nnrss.el (nnrss-request-list): Removed this function and related + functions, including the moreover stuff. + +2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnrss.el (nnrss-retrieve-groups): New function. + +2010-09-14 Juanma Barranquero <lekktu@gmail.com> + + * .dir-locals.el: Add no-byte-compile cookie. + +2010-09-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-read-active-for-groups): Run gnus-activate-group + for back end that doesn't support request-scan. + +2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-read-active-file-1): If gnus-agent isn't set, + then do request scans from the backends. + + * gnus-sum.el (gnus-summary-update-hook): Change default to nil, to + avoid running a hook per line, since this takes a lot of time, + profiling shows. + (gnus-summary-prepare-threads): Call `gnus-summary-highlight-line' + directly if gnus-visual-p is true. + +2010-09-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-read-active-for-groups): Check only subscribed + groups; replace mapcar with dolist which is a bit faster; pass groups + info to gnus-read-active-file-1. + (gnus-read-active-file-1): Scan only specified groups if the new + optional arg `infos' is given. + +2010-09-09 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mail-source.el (mail-source-fetch-pop): Use pop3-movemail again. + + * pop3.el (pop3-movemail): Removed. + (pop3-streaming-movemail): Renamed to pop3-movemail. + + * gnus-html.el (gnus-html-wash-tags): Refactor out the image bit, and + don't restrict end-tag searches to the end of the line. + +2010-09-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-get-unread-articles): Set the number of unread + articles of every unchecked group to t, which means unknown since the + server has never been opened. + +2010-09-08 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-show-alt-text): New command. + (gnus-html-browse-image): Ditto. + (gnus-html-wash-tags): Add the data to allow showing the ALT text and + to browse the image directly. + (gnus-html-wash-tags): Search for images first, so that <a><img> works + better. + + * gnus-async.el (gnus-async-article-callback): Call + `gnus-html-prefetch-images' unconditionally. + + * gnus-html.el (gnus-html-schedule-image-fetching): Decode entities + before feeding URLs to curl. + 2010-09-07 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-html.el (gnus-html-wash-tags, gnus-html-put-image): Mark cid and @@ -255,7 +761,7 @@ 2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-html.el (gnus-html-wash-tags): Don't show images that are really - small. They're probably tracking images. + small. They're probably tracking images. (gnus-html-wash-tags): Remove all <pre_int> place holders. (gnus-html-rescale-image): Yet another try at getting the image sizing right. @@ -409,12 +915,12 @@ * gnus-sum.el: As per discussion 3 years, 8 weeks, 3 days, 9 hours, 57 minutes, 56 seconds ago on the ding list, remove the `w' and `i' - bindings, as they aren't useful at all. `w' is moved to `W w'. + bindings, as they aren't useful at all. `w' is moved to `W w'. * gnus-move.el: Removed file, since it doesn't really work. * gnus-html.el (gnus-article-html): Tell w3m that the input is - UTF-8. This seems to fix problems with some German web feeds. + UTF-8. This seems to fix problems with some German web feeds. * gnus.el (gnus-group-startup-message): Put the xpm version of the logo at the top so that the proper colours are applied. @@ -3901,7 +4407,7 @@ (nntp-wait-for, nntp-retrieve-articles, nntp-async-trigger) (nntp-retrieve-headers-with-xover): Use nntp-insert-buffer-substring to copy data from unibyte buffer to multibyte current buffer. - (nntp-retrieve-headers, nntp-retrieve-groups); Use nntp-copy-to-buffer + (nntp-retrieve-headers, nntp-retrieve-groups): Use nntp-copy-to-buffer to copy data from unibyte current buffer to multibyte buffer. (nntp-make-process-buffer): Make process buffer unibyte.
--- a/lisp/gnus/auth-source.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/auth-source.el Wed Sep 22 15:46:51 2010 +0900 @@ -107,7 +107,8 @@ :version "23.2" ;; No Gnus :type `boolean) -(defcustom auth-sources '((:source "~/.authinfo.gpg")) +(defcustom auth-sources '((:source "~/.authinfo.gpg") + (:source "~/.authinfo")) "List of authentication sources. The default will get login and password information from a .gpg @@ -311,20 +312,23 @@ (setq result (mapcar (lambda (m) - (if (equal "password" m) - (let ((passwd (read-passwd "Password: "))) - (cond - ;; Secret Service API. - ((consp source) - (apply - 'secrets-create-item - (auth-get-source entry) name passwd spec)) - (t)) ;; netrc not implemented yes. - passwd) - (or - ;; the originally requested :user - user - "unknown-user"))) + (cond + ((equal "password" m) + (let ((passwd (read-passwd + (format "Password for %s on %s: " prot host)))) + (cond + ;; Secret Service API. + ((consp source) + (apply + 'secrets-create-item + (auth-get-source entry) name passwd spec)) + (t)) ;; netrc not implemented yes. + passwd)) + ((equal "login" m) + (or user + (read-string (format "User name for %s on %s: " prot host)))) + (t + "unknownuser"))) (if (consp mode) mode (list mode)))) (if (consp mode) result (car result))))
--- a/lisp/gnus/earcon.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/earcon.el Wed Sep 22 15:46:51 2010 +0900 @@ -151,8 +151,7 @@ (defun earcon-button-push (marker) ;; Push button starting at MARKER. - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (goto-char marker) (let* ((entry (earcon-button-entry)) (inhibit-point-motion-hooks t) @@ -214,8 +213,7 @@ (defun gnus-earcon-display () "Play sounds in message buffers." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (goto-char (point-min)) ;; Skip headers (unless (search-forward "\n\n" nil t)
--- a/lisp/gnus/flow-fill.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/flow-fill.el Wed Sep 22 15:46:51 2010 +0900 @@ -97,8 +97,7 @@ ;;;###autoload (defun fill-flowed (&optional buffer delete-space) - (save-excursion - (set-buffer (or (current-buffer) buffer)) + (with-current-buffer (or (current-buffer) buffer) (goto-char (point-min)) ;; Remove space stuffing. (while (re-search-forward "^\\( \\|>+ $\\)" nil t)
--- a/lisp/gnus/gnus-agent.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-agent.el Wed Sep 22 15:46:51 2010 +0900 @@ -184,7 +184,7 @@ :type 'boolean :group 'gnus-agent) -(defcustom gnus-agent-auto-agentize-methods '(nntp) +(defcustom gnus-agent-auto-agentize-methods nil "Initially, all servers from these methods are agentized. The user may remove or add servers using the Server buffer. See Info node `(gnus)Server Buffer'." @@ -305,8 +305,7 @@ `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) (when (and gnus-agent-need-update-total-fetched-for (not gnus-agent-inhibit-update-total-fetched-for)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq gnus-agent-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) @@ -474,8 +473,7 @@ (defun gnus-agent-stop-fetch () "Save all data structures and clean up." (setq gnus-agent-spam-hashtb nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (widen))) (defmacro gnus-agent-with-fetch (&rest forms) @@ -1608,8 +1606,7 @@ nntp-server-buffer (point-min) (point-max)) (setq pos (nreverse pos))))) ;; Then save these articles into the Agent. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) @@ -1693,8 +1690,7 @@ (setq date (or date t)) (let (gnus-agent-article-alist group alist beg end) - (save-excursion - (set-buffer gnus-agent-overview-buffer) + (with-current-buffer gnus-agent-overview-buffer (when (nnheader-find-nov-line article) (forward-word 1) (setq beg (point)) @@ -1705,9 +1701,8 @@ (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) - (save-excursion - (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + (with-current-buffer (gnus-get-buffer-create + (format " *Gnus agent overview %s*"group)) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors @@ -1939,9 +1934,7 @@ 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" (gnus-compress-sequence articles t)) - (save-excursion - (set-buffer nntp-server-buffer) - + (with-current-buffer nntp-server-buffer (if articles (progn (gnus-message 7 "Fetching headers for %s..." @@ -2111,12 +2104,12 @@ (let* ((gnus-agent-read-agentview group) (file-name-coding-system nnmail-pathname-coding-system) (agentview (gnus-agent-article-name ".agentview" group))) - (when (file-exists-p agentview) - (setq gnus-agent-article-alist - (gnus-cache-file-contents - agentview - 'gnus-agent-file-loading-cache - 'gnus-agent-read-agentview))))) + (setq gnus-agent-article-alist + (and (file-exists-p agentview) + (gnus-cache-file-contents + agentview + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview))))) (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." @@ -2360,7 +2353,6 @@ (local (or local (gnus-agent-load-local))) (symb (intern gmane local)) (minmax (and (boundp symb) (symbol-value symb)))) - (if (cond ((and minmax (or (not (eq min (car minmax))) (not (eq max (cdr minmax)))) @@ -2385,7 +2377,7 @@ (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." - (gnus-message 1 msg) + (gnus-message 1 "%s" msg) t) ;;;###autoload @@ -2767,8 +2759,7 @@ (defun gnus-category-setup-buffer () (unless (get-buffer gnus-category-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-category-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-category-buffer) (gnus-category-mode)))) (defun gnus-category-prepare () @@ -3132,7 +3123,7 @@ group overview (gnus-gethash-safe group orig) articles force)))) (kill-buffer overview)))) - (gnus-message 4 (gnus-agent-expire-done-message))))) + (gnus-message 4 "%s" (gnus-agent-expire-done-message))))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set @@ -3557,7 +3548,7 @@ expiring-group overview active articles force)))))))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) - (gnus-message 4 (gnus-agent-expire-done-message)))))) + (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))) (defun gnus-agent-expire-done-message () (if (and (> gnus-verbose 4)
--- a/lisp/gnus/gnus-art.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-art.el Wed Sep 22 15:46:51 2010 +0900 @@ -6406,7 +6406,7 @@ (defun gnus-article-describe-briefly () "Describe article mode commands briefly." (interactive) - (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[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"))) + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-article-mode-map>\\[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-check-buffer () "Beep if not in an article buffer."
--- a/lisp/gnus/gnus-async.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-async.el Wed Sep 22 15:46:51 2010 +0900 @@ -145,8 +145,7 @@ (when (and (gnus-buffer-live-p summary) gnus-asynchronous (gnus-group-asynchronous-p group)) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let ((next (caadr (gnus-data-find-list article)))) (when next (if (not (fboundp 'run-with-idle-timer)) @@ -205,8 +204,7 @@ (when (and do-fetch article) ;; We want to fetch some more articles. - (save-excursion - (set-buffer summary) + (with-current-buffer summary (let (mark) (gnus-async-set-buffer) (goto-char (point-max)) @@ -237,13 +235,13 @@ (setq gnus-async-current-prefetch-article nil) (when arg (gnus-async-set-buffer) - (when gnus-async-post-fetch-function - (save-excursion - (save-restriction - (narrow-to-region mark (point-max)) - ;; Prefetch images for the groups that want that. - (when (fboundp 'gnus-html-prefetch-images) - (gnus-html-prefetch-images summary)) + (save-excursion + (save-restriction + (narrow-to-region mark (point-max)) + ;; Prefetch images for the groups that want that. + (when (fboundp 'gnus-html-prefetch-images) + (gnus-html-prefetch-images summary)) + (when gnus-async-post-fetch-function (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore (setq
--- a/lisp/gnus/gnus-bcklg.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-bcklg.el Wed Sep 22 15:46:51 2010 +0900 @@ -40,8 +40,7 @@ (defun gnus-backlog-buffer () "Return the backlog buffer." (or (get-buffer gnus-backlog-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-backlog-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-backlog-buffer) (buffer-disable-undo) (setq buffer-read-only t) (get-buffer gnus-backlog-buffer)))) @@ -76,8 +75,7 @@ (gnus-backlog-remove-oldest-article)) (push ident gnus-backlog-articles) ;; Insert the new article. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (let (buffer-read-only) (goto-char (point-max)) (unless (bolp) @@ -90,8 +88,7 @@ (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (goto-char (point-min)) (if (zerop (buffer-size)) () ; The buffer is empty. @@ -114,8 +111,7 @@ beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (let (buffer-read-only) (when (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog @@ -138,8 +134,7 @@ beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (if (not (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog ident))) @@ -150,8 +145,7 @@ (setq end (next-single-property-change (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) - (save-excursion - (and buffer (set-buffer buffer)) + (with-current-buffer (or (current-buffer) buffer) (let ((buffer-read-only nil)) (erase-buffer) (insert-buffer-substring gnus-backlog-buffer beg end)))
--- a/lisp/gnus/gnus-cache.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-cache.el Wed Sep 22 15:46:51 2010 +0900 @@ -180,8 +180,7 @@ ;; Save the article in the cache. (if (file-exists-p file) t ; The article already is saved. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (require 'gnus-art) (let ((gnus-use-cache nil) (gnus-article-decode-hook nil)) @@ -554,8 +553,7 @@ (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) beg end) (gnus-cache-save-buffers) - (save-excursion - (set-buffer cache-buf) + (with-current-buffer cache-buf (erase-buffer) (let ((coding-system-for-read gnus-cache-overview-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) @@ -844,8 +842,7 @@ ,@body) (when (and gnus-cache-need-update-total-fetched-for (not gnus-cache-inhibit-update-total-fetched-for)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq gnus-cache-need-update-total-fetched-for nil) (gnus-group-update-group ,group t)))))
--- a/lisp/gnus/gnus-demon.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-demon.el Wed Sep 22 15:46:51 2010 +0900 @@ -291,11 +291,9 @@ (let ((win (current-window-configuration))) (unwind-protect (save-window-excursion - (save-excursion - (when (gnus-alive-p) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-get-new-news))))) + (when (gnus-alive-p) + (with-current-buffer gnus-group-buffer + (gnus-group-get-new-news)))) (set-window-configuration win)))) (defun gnus-demon-add-scan-timestamps ()
--- a/lisp/gnus/gnus-group.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-group.el Wed Sep 22 15:46:51 2010 +0900 @@ -509,7 +509,10 @@ (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) - (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d) + (?U (if (gnus-active gnus-tmp-group) + (gnus-number-of-unseen-articles-in-group gnus-tmp-group) + "*") + ?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) @@ -675,7 +678,7 @@ "R" gnus-group-make-rss-group "c" gnus-group-customize "z" gnus-group-compact-group - "x" gnus-group-nnimap-expunge + "x" gnus-group-expunge-group "\177" gnus-group-delete-group [delete] gnus-group-delete-group) @@ -1273,7 +1276,7 @@ (zerop number)) (zerop (buffer-size))) ;; No groups in the buffer. - (gnus-message 5 gnus-no-groups-message)) + (gnus-message 5 "%s" gnus-no-groups-message)) ;; We have some groups displayed. (goto-char (point-max)) (when (or (not gnus-group-goto-next-group-function) @@ -3163,21 +3166,17 @@ 'summary 'group))) (error "Couldn't enter %s" dir)))) -(autoload 'nnimap-expunge "nnimap") -(autoload 'nnimap-acl-get "nnimap") -(autoload 'nnimap-acl-edit "nnimap") - -(defun gnus-group-nnimap-expunge (group) +(defun gnus-group-expunge-group (group) "Expunge deleted articles in current nnimap GROUP." (interactive (list (gnus-group-group-name))) - (let ((mailbox (gnus-group-real-name group)) method) - (unless group - (error "No group on current line")) - (unless (gnus-get-info group) - (error "Killed group; can't be edited")) - (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group)))) - (error "%s is not an nnimap group" group)) - (nnimap-expunge mailbox (cadr method)))) + (let ((method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-expunge-group (car method))) + (error "%s does not support expunging" (car method)) + (gnus-request-expunge-group group method)))) + +(autoload 'nnimap-acl-get "nnimap") +(autoload 'nnimap-acl-edit "nnimap") (defun gnus-group-nnimap-edit-acl (group) "Edit the Access Control List of current nnimap GROUP." @@ -4136,7 +4135,7 @@ (gnus-gethash mname gnus-description-hashtb)) (setq desc (gnus-group-get-description group)) (gnus-read-descriptions-file method)) - (gnus-message 1 + (gnus-message 1 "%s" (or desc (gnus-gethash group gnus-description-hashtb) "No description available"))))) @@ -4297,11 +4296,9 @@ (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"))))) + (gnus-message 6 "Editing a %s kill file (Type %s to exit)" + (if group "local" "global") + (substitute-command-keys "\\[gnus-kill-file-exit]"))) (defun gnus-group-edit-local-kill (article group) "Edit a local kill file." @@ -4392,7 +4389,7 @@ (defun gnus-group-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[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"))) + (gnus-message 7 "%s" (substitute-command-keys "\\<gnus-group-mode-map>\\[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.
--- a/lisp/gnus/gnus-html.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-html.el Wed Sep 22 15:46:51 2010 +0900 @@ -30,16 +30,14 @@ (eval-when-compile (require 'cl)) (eval-when-compile (require 'mm-decode)) -(require 'mm-url) -(defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/") - "Where Gnus will cache images it downloads from the web." - :version "24.1" - :group 'gnus-art - :type 'directory) +(require 'gnus-art) +(require 'mm-url) +(require 'url) +(require 'url-cache) -(defcustom gnus-html-cache-size 500000000 - "The size of the Gnus image cache." +(defcustom gnus-html-image-cache-ttl (days-to-time 7) + "Time in seconds used to cache the image on disk." :version "24.1" :group 'gnus-art :type 'integer) @@ -70,8 +68,31 @@ (let ((map (make-sparse-keymap))) (define-key map "u" 'gnus-article-copy-string) (define-key map "i" 'gnus-html-insert-image) + (define-key map "v" 'gnus-html-browse-url) map)) +(defvar gnus-html-displayed-image-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'gnus-html-show-alt-text) + (define-key map "i" 'gnus-html-browse-image) + (define-key map "\r" 'gnus-html-browse-url) + (define-key map "u" 'gnus-article-copy-string) + (define-key map [tab] 'widget-forward) + map)) + +(defun gnus-html-cache-expired (url ttl) + "Check if URL is cached for more than TTL." + (cond (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + (t (let ((cache-time (url-is-cached url))) + (if cache-time + (time-less-p + (time-add + cache-time + ttl) + (current-time)) + t))))) + ;;;###autoload (defun gnus-article-html (&optional handle) (let ((article-buffer (current-buffer))) @@ -102,6 +123,7 @@ "-I" "UTF-8" "-O" "UTF-8" "-o" "ext_halfdump=1" + "-o" "display_ins_del=2" "-o" "pre_conv=1" "-t" (format "%s" tab-width) "-cols" (format "%s" gnus-html-frame-width) @@ -111,15 +133,111 @@ (defvar gnus-article-mouse-face) -(defun gnus-html-wash-tags () +(defun gnus-html-pre-wash () + (goto-char (point-min)) + (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "<a name[^\n>]+>" nil t) + (replace-match "" t t))) + +(defun gnus-html-wash-images () + "Run through current buffer and replace img tags by images." (let (tag parameters string start end images url) (goto-char (point-min)) - (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) - (replace-match "" t t)) + ;; Search for all the images first. + (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t) + (setq parameters (match-string 1) + start (match-beginning 0)) + (delete-region start (point)) + (when (search-forward "</img_alt>" (line-end-position) t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) + (when (string-match "src=\"\\([^\"]+\\)" parameters) + (setq url (match-string 1 parameters)) + (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) + (if (string-match "^cid:\\(.*\\)" url) + ;; URLs with cid: have their content stashed in other + ;; parts of the MIME structure, so just insert them + ;; immediately. + (let ((handle (mm-get-content-id + (setq url (match-string 1 url)))) + image) + (when handle + (mm-with-part handle + (setq image (gnus-create-image (buffer-string) + nil t)))) + (when image + (let ((string (buffer-substring start end))) + (delete-region start end) + (gnus-put-image image (gnus-string-or string "*") 'cid) + (gnus-add-image 'cid image)))) + ;; Normal, external URL. + (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" + parameters) + (match-string 2 parameters)))) + (if (gnus-html-image-url-blocked-p + url + (if (buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-blocked-images) + gnus-blocked-images)) + (progn + (widget-convert-button + 'link start end + :action 'gnus-html-insert-image + :help-echo url + :keymap gnus-html-image-map + :button-keymap gnus-html-image-map) + (let ((overlay (gnus-make-overlay start end)) + (spec (list url + (set-marker (make-marker) start) + (set-marker (make-marker) end) + alt-text))) + (gnus-overlay-put overlay 'local-map gnus-html-image-map) + (gnus-overlay-put overlay 'gnus-image spec) + (gnus-put-text-property start end 'gnus-image-url url) + (gnus-put-text-property + start end + 'gnus-image spec))) + ;; Non-blocked url + (let ((width + (when (string-match "width=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters)))) + (height + (when (string-match "height=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters))))) + ;; Don't fetch images that are really small. They're + ;; probably tracking pictures. + (when (and (or (null height) + (> height 4)) + (or (null width) + (> width 4))) + (gnus-html-display-image url start end alt-text)))))))))) + +(defun gnus-html-display-image (url start end alt-text) + "Display image at URL on text from START to END. +Use ALT-TEXT for the image string." + (if (gnus-html-cache-expired url gnus-html-image-cache-ttl) + ;; We don't have it, so schedule it for fetching + ;; asynchronously. + (gnus-html-schedule-image-fetching + (current-buffer) + (list url + (set-marker (make-marker) start) + (set-marker (make-marker) end) + alt-text)) + ;; It's already cached, so just insert it. + (gnus-html-put-image (gnus-html-get-image-data url) + start end url alt-text))) + +(defun gnus-html-wash-tags () + (let (tag parameters string start end images url) + (gnus-html-pre-wash) + (gnus-html-wash-images) + (goto-char (point-min)) - (while (re-search-forward "<a name[^\n>]+>" nil t) - (replace-match "" t t)) - (goto-char (point-min)) + ;; Then do the other tags. (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) (setq tag (match-string 1) parameters (match-string 2) @@ -127,78 +245,12 @@ (when (plusp (length parameters)) (set-text-properties 0 (1- (length parameters)) nil parameters)) (delete-region start (point)) - (when (search-forward (concat "</" tag ">") (line-end-position) t) + (when (search-forward (concat "</" tag ">") nil t) (delete-region (match-beginning 0) (match-end 0))) (setq end (point)) (cond ;; Fetch and insert a picture. - ((equal tag "img_alt") - (when (string-match "src=\"\\([^\"]+\\)" parameters) - (setq url (match-string 1 parameters)) - (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) - (if (string-match "^cid:\\(.*\\)" url) - ;; URLs with cid: have their content stashed in other - ;; parts of the MIME structure, so just insert them - ;; immediately. - (let ((handle (mm-get-content-id - (setq url (match-string 1 url)))) - image) - (when handle - (mm-with-part handle - (setq image (gnus-create-image (buffer-string) - nil t)))) - (when image - (let ((string (buffer-substring start end))) - (delete-region start end) - (gnus-put-image image (gnus-string-or string "*") 'cid) - (gnus-add-image 'cid image)))) - ;; Normal, external URL. - (if (gnus-html-image-url-blocked-p - url - (if (buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - gnus-blocked-images) - gnus-blocked-images)) - (progn - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map) - (let ((overlay (gnus-make-overlay start end)) - (spec (list url - (set-marker (make-marker) start) - (set-marker (make-marker) end)))) - (gnus-overlay-put overlay 'local-map gnus-html-image-map) - (gnus-overlay-put overlay 'gnus-image spec) - (gnus-put-text-property - start end - 'gnus-image spec))) - (let ((file (gnus-html-image-id url)) - width height) - (when (string-match "height=\"?\\([0-9]+\\)" parameters) - (setq height (string-to-number (match-string 1 parameters)))) - (when (string-match "width=\"?\\([0-9]+\\)" parameters) - (setq width (string-to-number (match-string 1 parameters)))) - ;; Don't fetch images that are really small. They're - ;; probably tracking pictures. - (when (and (or (null height) - (> height 4)) - (or (null width) - (> width 4))) - (if (file-exists-p file) - ;; It's already cached, so just insert it. - (let ((string (buffer-substring start end))) - ;; Delete the ALT text. - (delete-region start end) - (gnus-html-put-image file (point) string)) - ;; We don't have it, so schedule it for fetching - ;; asynchronously. - (push (list url - (set-marker (make-marker) start) - (point-marker)) - images)))))))) + ((equal tag "img_alt")) ;; Add a link. ((or (equal tag "a") (equal tag "A")) @@ -218,6 +270,38 @@ ;; should be deleted. ((equal tag "IMG_ALT") (delete-region start end)) + ;; w3m does not normalize the case + ((or (equal tag "b") + (equal tag "B")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold)) + ((or (equal tag "u") + (equal tag "U")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline)) + ((or (equal tag "i") + (equal tag "I")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic)) + ((or (equal tag "s") + (equal tag "S")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru)) + ((or (equal tag "ins") + (equal tag "INS")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline)) + ;; Handle different UL types + ((equal tag "_SYMBOL") + (when (string-match "TYPE=\\(.+\\)" parameters) + (let ((type (string-to-number (match-string 1 parameters)))) + (delete-region start end) + (cond ((= type 33) (insert " ")) + ((= type 34) (insert " ")) + ((= type 35) (insert " ")) + ((= type 36) (insert " ")) + ((= type 37) (insert " ")) + ((= type 38) (insert " ")) + ((= type 39) (insert " ")) + ((= type 40) (insert " ")) + ((= type 42) (insert " ")) + ((= type 43) (insert " ")) + (t (insert " ")))))) ;; Whatever. Just ignore the tag. (t )) @@ -227,97 +311,114 @@ ;; off any </pre_int>s that were left over. (while (re-search-forward "</pre_int>\\|</internal>" nil t) (replace-match "" t t)) - (when images - (gnus-html-schedule-image-fetching (current-buffer) (nreverse images))) (mm-url-decode-entities))) (defun gnus-html-insert-image () "Fetch and insert the image under point." (interactive) - (gnus-html-schedule-image-fetching - (current-buffer) (list (get-text-property (point) 'gnus-image)))) + (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image))) + +(defun gnus-html-show-alt-text () + "Show the ALT text of the image under point." + (interactive) + (message "%s" (get-text-property (point) 'gnus-alt-text))) + +(defun gnus-html-browse-image () + "Browse the image under point." + (interactive) + (browse-url (get-text-property (point) 'gnus-image-url))) -(defun gnus-html-schedule-image-fetching (buffer images) - (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s" - buffer images) - (let* ((url (caar images)) - (process (start-process - "images" nil "curl" - "-s" "--create-dirs" - "--location" - "--max-time" "60" - "-o" (gnus-html-image-id url) - url))) - (process-kill-without-query process) - (set-process-sentinel process 'gnus-html-curl-sentinel) - (gnus-set-process-plist process (list 'images images - 'buffer buffer)))) +(defun gnus-html-browse-url () + "Browse the image under point." + (interactive) + (let ((url (get-text-property (point) 'gnus-string))) + (if (not url) + (message "No URL at point") + (browse-url url)))) -(defun gnus-html-image-id (url) - (expand-file-name (sha1 url) gnus-html-cache-directory)) +(defun gnus-html-schedule-image-fetching (buffer image) + "Retrieve IMAGE, and place it into BUFFER on arrival." + (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s" + buffer image) + (ignore-errors + (url-retrieve (car image) + 'gnus-html-image-fetched + (list buffer image)))) -(defun gnus-html-curl-sentinel (process event) - (when (string-match "finished" event) - (let* ((images (gnus-process-get process 'images)) - (buffer (gnus-process-get process 'buffer)) - (spec (pop images)) - (file (gnus-html-image-id (car spec)))) - (when (and (buffer-live-p buffer) - ;; If the position of the marker is 1, then that - ;; means that the text it was in has been deleted; - ;; i.e., that the user has selected a different - ;; article before the image arrived. - (not (= (marker-position (cadr spec)) (point-min)))) - (with-current-buffer buffer - (let ((inhibit-read-only t) - (string (buffer-substring (cadr spec) (caddr spec)))) - (delete-region (cadr spec) (caddr spec)) - (gnus-html-put-image file (cadr spec) string)))) - (when images - (gnus-html-schedule-image-fetching buffer images))))) +(defun gnus-html-image-fetched (status buffer image) + (url-store-in-cache (current-buffer)) + (when (and (search-forward "\n\n" nil t) + (buffer-live-p buffer) + ;; If the `image' has no marker, do not replace anything + (cadr image) + ;; If the position of the marker is 1, then that + ;; means that the text it was in has been deleted; + ;; i.e., that the user has selected a different + ;; article before the image arrived. + (not (= (marker-position (cadr image)) + (with-current-buffer buffer + (point-min))))) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image)))))) + (kill-buffer (current-buffer))) -(defun gnus-html-put-image (file point string) +(defun gnus-html-get-image-data (url) + "Get image data for URL. +Return a string with image data." + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (when (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max))))) + +(defun gnus-html-put-image (data start end &optional url alt-text) (when (gnus-graphic-display-p) (let* ((image (ignore-errors - (gnus-create-image file))) - (size (and image - (if (featurep 'xemacs) - (cons (glyph-width image) (glyph-height image)) - (image-size image t))))) + (gnus-create-image data nil t))) + (size (and image + (if (featurep 'xemacs) + (cons (glyph-width image) (glyph-height image)) + (image-size image t))))) (save-excursion - (goto-char point) - (if (and image - ;; Kludge to avoid displaying 30x30 gif images, which - ;; seems to be a signal of a broken image. - (not (and (if (featurep 'xemacs) - (glyphp image) - (listp image)) - (eq (if (featurep 'xemacs) - (let ((data (cdadar (specifier-spec-list - (glyph-image image))))) - (and (vectorp data) - (aref data 0))) - (plist-get (cdr image) :type)) - 'gif) - (= (car size) 30) - (= (cdr size) 30)))) - (progn - (setq image (gnus-html-rescale-image image file size)) - (gnus-put-image image - (gnus-string-or string "*") - 'external) - (gnus-add-image 'external image) - t) - (insert string) - (when (fboundp 'find-image) - (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) - (gnus-put-image image - (gnus-string-or string "*") - 'internal) - (gnus-add-image 'internal image)) - nil))))) + (goto-char start) + (let ((alt-text (or alt-text (buffer-substring-no-properties start end)))) + (if (and image + ;; Kludge to avoid displaying 30x30 gif images, which + ;; seems to be a signal of a broken image. + (not (and (if (featurep 'xemacs) + (glyphp image) + (listp image)) + (eq (if (featurep 'xemacs) + (let ((d (cdadar (specifier-spec-list + (glyph-image image))))) + (and (vectorp d) + (aref d 0))) + (plist-get (cdr image) :type)) + 'gif) + (= (car size) 30) + (= (cdr size) 30)))) + ;; Good image, add it! + (let ((image (gnus-html-rescale-image image data size))) + (delete-region start end) + (gnus-put-image image alt-text 'external) + (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map + gnus-html-displayed-image-map) + (gnus-put-text-property start (point) 'gnus-alt-text alt-text) + (when url + (gnus-put-text-property start (point) 'gnus-image-url url)) + (gnus-add-image 'external image) + t) + ;; Bad image, try to show something else + (delete-region start end) + (when (fboundp 'find-image) + (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) + (gnus-put-image image alt-text 'internal) + (gnus-add-image 'internal image)) + nil)))))) -(defun gnus-html-rescale-image (image file size) +(defun gnus-html-rescale-image (image data size) (if (or (not (fboundp 'imagemagick-types)) (not (get-buffer-window (current-buffer)))) image @@ -330,37 +431,19 @@ (- (nth 3 edges) (nth 1 edges))))) scaled-image) (when (> height window-height) - (setq image (or (create-image file 'imagemagick nil + (setq image (or (create-image data 'imagemagick t :height window-height) image)) (setq size (image-size image t))) (when (> (car size) window-width) (setq image (or - (create-image file 'imagemagick nil + (create-image data 'imagemagick t :width window-width) image))) image))) -(defun gnus-html-prune-cache () - (let ((total-size 0) - files) - (dolist (file (directory-files gnus-html-cache-directory t nil t)) - (let ((attributes (file-attributes file))) - (unless (nth 0 attributes) - (incf total-size (nth 7 attributes)) - (push (list (time-to-seconds (nth 5 attributes)) - (nth 7 attributes) file) - files)))) - (when (> total-size gnus-html-cache-size) - (setq files (sort files (lambda (f1 f2) - (< (car f1) (car f2))))) - (dolist (file files) - (when (> total-size gnus-html-cache-size) - (decf total-size (cadr file)) - (delete-file (nth 2 file))))))) - (defun gnus-html-image-url-blocked-p (url blocked-images) -"Find out if URL is blocked by BLOCKED-IMAGES." + "Find out if URL is blocked by BLOCKED-IMAGES." (let ((ret (and blocked-images (string-match blocked-images url)))) (if ret @@ -375,37 +458,23 @@ This only works if the article in question is HTML." (interactive) (gnus-with-article-buffer - (let ((overlays (overlays-in (point-min) (point-max))) - overlay images) - (while (setq overlay (pop overlays)) - (when (overlay-get overlay 'gnus-image) - (push (overlay-get overlay 'gnus-image) images))) - (if (not images) - (message "No images to show") - (gnus-html-schedule-image-fetching (current-buffer) images))))) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((o (overlay-get overlay 'gnus-image))) + (when o + (apply 'gnus-html-display-image o)))))) ;;;###autoload (defun gnus-html-prefetch-images (summary) - (let (blocked-images urls) - (when (buffer-live-p summary) - (with-current-buffer summary - (setq blocked-images gnus-blocked-images)) + (when (buffer-live-p summary) + (let ((blocked-images (with-current-buffer summary + gnus-blocked-images))) (save-match-data (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t) (let ((url (match-string 1))) (unless (gnus-html-image-url-blocked-p url blocked-images) - (unless (file-exists-p (gnus-html-image-id url)) - (push url urls) - (push (gnus-html-image-id url) urls) - (push "-o" urls))))) - (let ((process - (apply 'start-process - "images" nil "curl" - "-s" "--create-dirs" - "--location" - "--max-time" "60" - urls))) - (process-kill-without-query process)))))) + (when (gnus-html-cache-expired url gnus-html-image-cache-ttl) + (gnus-html-schedule-image-fetching nil + (list url)))))))))) (provide 'gnus-html)
--- a/lisp/gnus/gnus-int.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-int.el Wed Sep 22 15:46:51 2010 +0900 @@ -179,10 +179,7 @@ (format " on %s" (nth 1 method))))) (gnus-run-hooks 'gnus-open-server-hook) (prog1 - (condition-case () - (setq result (gnus-open-server method)) - (quit (message "Quit gnus-check-server") - nil)) + (setq result (gnus-open-server method)) (unless silent (gnus-message 5 "Opening %s server%s...%s" (car method) (if (equal (nth 1 method) "") "" @@ -225,6 +222,10 @@ ;;; Interface functions to the backends. ;;; +(defun gnus-method-denied-p (method) + (eq (nth 1 (assoc method gnus-opened-servers)) + 'denied)) + (defun gnus-open-server (gnus-command-method) "Open a connection to GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) @@ -244,9 +245,8 @@ (nth 1 gnus-command-method) (nthcdr 2 gnus-command-method)) (error - (gnus-message 1 (format - "Unable to open server %s due to: %s" - server (error-message-string err))) + (gnus-message 1 "Unable to open server %s due to: %s" + server (error-message-string err)) nil) (quit (gnus-message 1 "Quit trying to open server %s" server) @@ -275,8 +275,10 @@ (not gnus-batch-mode) (gnus-y-or-n-p (format - "Unable to open server %s, go offline? " - server))) + "Unable to open server %s (%s), go offline? " + server + (nnheader-get-report + (car gnus-command-method))))) (setq open-offline t) 'offline) (t @@ -319,6 +321,22 @@ (funcall (gnus-get-function gnus-command-method 'request-list) (nth 1 gnus-command-method))) +(defun gnus-finish-retrieve-group-infos (gnus-command-method infos data) + "Read and update infos from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos) + (nth 1 gnus-command-method) + infos data)) + +(defun gnus-retrieve-group-data-early (gnus-command-method infos) + "Start early async retrival of data from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early) + (nth 1 gnus-command-method) + infos)) + (defun gnus-request-list-newsgroups (gnus-command-method) "Request the newsgroups file from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) @@ -358,7 +376,7 @@ (funcall (gnus-get-function gnus-command-method 'request-compact) (nth 1 gnus-command-method))) -(defun gnus-request-group (group &optional dont-check gnus-command-method) +(defun gnus-request-group (group &optional dont-check gnus-command-method info) "Request GROUP. If DONT-CHECK, no information is required." (let ((gnus-command-method (or gnus-command-method (inline (gnus-find-method-for-group group))))) @@ -367,7 +385,8 @@ (inline (gnus-server-to-method gnus-command-method)))) (funcall (inline (gnus-get-function gnus-command-method 'request-group)) (gnus-group-real-name group) (nth 1 gnus-command-method) - dont-check))) + dont-check + info))) (defun gnus-list-active-group (group) "Request active information on GROUP." @@ -490,8 +509,7 @@ (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))) @@ -523,8 +541,7 @@ (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (1- (point)))))) @@ -537,6 +554,14 @@ (funcall (gnus-get-function gnus-command-method 'request-post) (nth 1 gnus-command-method))) +(defun gnus-request-expunge-group (group gnus-command-method) + "Expunge GROUP, which is removing articles that have been marked as deleted." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-expunge-group) + (gnus-group-real-name group) + (nth 1 gnus-command-method))) + (defun gnus-request-scan (group gnus-command-method) "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD. If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
--- a/lisp/gnus/gnus-kill.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-kill.el Wed Sep 22 15:46:51 2010 +0900 @@ -349,8 +349,7 @@ (defun gnus-expunge (marks) "Remove lines marked with MARKS." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-limit-to-marks marks 'reverse))) (defun gnus-apply-kill-file-unless-scored () @@ -442,8 +441,7 @@ (progn (delete-region beg (point)) (insert (or (eval form) ""))) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (ignore-errors (eval form))))) (and (buffer-modified-p) gnus-kill-save-kill-file @@ -555,8 +553,7 @@ (and (eq 'quote (car (nth 2 object))) (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Gnus PP*")) + (with-current-buffer (gnus-get-buffer-create "*Gnus PP*") (buffer-disable-undo) (erase-buffer) (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) @@ -610,8 +607,7 @@ 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) - (when (save-excursion - (set-buffer gnus-article-buffer) + (when (with-current-buffer gnus-article-buffer (goto-char (point-min)) (setq did-kill (re-search-forward regexp nil t))) (cond ((stringp form) ;Keyboard macro.
--- a/lisp/gnus/gnus-logic.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-logic.el Wed Sep 22 15:46:51 2010 +0900 @@ -179,8 +179,7 @@ (defun gnus-advanced-body (header match type) (when (string= header "all") (setq header "article")) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (let* ((request-func (cond ((string= "head" header) 'gnus-request-head) ((string= "body" header)
--- a/lisp/gnus/gnus-range.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-range.el Wed Sep 22 15:46:51 2010 +0900 @@ -59,6 +59,36 @@ (setq list2 (cdr list2))) list1)) +(defun gnus-range-nconcat (&rest ranges) + "Return a range comprising all the RANGES, which are pre-sorted. +RANGES will be destructively altered." + (setq ranges (delete nil ranges)) + (let* ((result (gnus-range-normalize (pop ranges))) + (last (last result))) + (dolist (range ranges) + (setq range (gnus-range-normalize range)) + ;; Normalize the single-number case, so that we don't need to + ;; special-case that so much. + (when (numberp (car last)) + (setcar last (cons (car last) (car last)))) + (when (numberp (car range)) + (setcar range (cons (car range) (car range)))) + (if (= (1+ (cdar last)) (caar range)) + (progn + (setcdr (car last) (cdar range)) + (setcdr last (cdr range))) + (setcdr last range) + ;; Denormalize back, since we couldn't join the ranges up. + (when (= (caar range) (cdar range)) + (setcar range (caar range))) + (when (= (caar last) (cdar last)) + (setcar last (caar last)))) + (setq last (last last))) + (if (and (consp (car result)) + (= (length result) 1)) + (car result) + result))) + (defun gnus-range-difference (range1 range2) "Return the range of elements in RANGE1 that do not appear in RANGE2. Both ranges must be in ascending order."
--- a/lisp/gnus/gnus-registry.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-registry.el Wed Sep 22 15:46:51 2010 +0900 @@ -241,8 +241,7 @@ "Save the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) - (save-excursion - (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) + (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*") (make-local-variable 'version-control) (setq version-control gnus-backup-startup-file) (setq buffer-file-name file) @@ -674,8 +673,7 @@ word words) (if (or (not (gnus-registry-fetch-extra id 'keywords)) force) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (article-goto-body) (save-window-excursion (save-restriction @@ -783,7 +781,7 @@ (function-name (format function-format variant-name)) (shortcut (format "%c" data)) (shortcut (if remove (upcase shortcut) shortcut))) - (unintern function-name) + (unintern function-name obarray) (eval `(defun ;; function name
--- a/lisp/gnus/gnus-score.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-score.el Wed Sep 22 15:46:51 2010 +0900 @@ -708,8 +708,7 @@ ;; Change score file to the "all.SCORE" file. (when (eq symp 'a) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file ;; This is a kludge; yes... (cond @@ -735,14 +734,12 @@ (when (eq symp 'a) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file))))) (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Score Help*")) + (with-current-buffer (gnus-get-buffer-create "*Score Help*") (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) @@ -1117,8 +1114,8 @@ (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) + 4 "%s" (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) (defun gnus-score-edit-all-score () "Edit the all.SCORE file." @@ -1145,8 +1142,8 @@ (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) + 4 "%s" (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) (defun gnus-score-edit-file-at-point (&optional format) "Edit score file at point in Score Trace buffers. @@ -1270,8 +1267,7 @@ exclude-files)) gnus-scores-exclude-files)) (when local - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (while local (and (consp (car local)) (symbolp (caar local)) @@ -1395,7 +1391,7 @@ (if err (progn (ding) - (gnus-message 3 err) + (gnus-message 3 "%s" err) (sit-for 2) nil) alist))))) @@ -1528,8 +1524,7 @@ (cons (cons header (or gnus-summary-default-score 0)) gnus-scores-articles)))) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Headers*")) + (with-current-buffer (gnus-get-buffer-create "*Headers*") (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1854,8 +1849,7 @@ ;; Change score file to the adaptive score file. All entries that ;; this function makes will be put into this file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-score-file-name @@ -1946,15 +1940,13 @@ (setq rest entries))) (setq entries rest)))) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file)) (list (cons "references" news))))) (defun gnus-score-add-followups (header score scores &optional thread) "Add a score entry to the adapt file." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let* ((id (mail-header-id header)) (scores (car scores)) entry dont) @@ -2282,8 +2274,7 @@ "Create adaptive score rules for this newsgroup." (when gnus-newsgroup-adaptive ;; We change the score file to the adaptive score file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-home-score-file gnus-newsgroup-name t) @@ -2697,8 +2688,7 @@ (trans (cdr (assq ?: nnheader-file-name-translation-alist))) (group-trans (nnheader-translate-file-chars group t)) ofiles not-match regexp) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus score files*")) + (with-current-buffer (gnus-get-buffer-create "*gnus score files*") (buffer-disable-undo) ;; Go through all score file names and create regexp with them ;; as the source.
--- a/lisp/gnus/gnus-srvr.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-srvr.el Wed Sep 22 15:46:51 2010 +0900 @@ -976,7 +976,7 @@ (defun gnus-browse-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 6 + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-browse-mode-map>\\[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 ()
--- a/lisp/gnus/gnus-start.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-start.el Wed Sep 22 15:46:51 2010 +0900 @@ -268,7 +268,7 @@ (mapconcat 'identity '("^to\\." ; not "real" groups "^[0-9. \t]+\\( \\|$\\)" ; all digits in name - "^[\"][]\"[#'()]" ; bogus characters + "^[\"][\"#'()]" ; bogus characters ) "\\|") "*A regexp to match uninteresting newsgroups in the active file. @@ -594,8 +594,7 @@ (defun gnus-subscribe-hierarchically (newgroup) "Subscribe new NEWGROUP 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)) + (with-current-buffer (nnheader-find-file-noselect gnus-current-startup-file) (prog1 (let ((groupkey newgroup) before) (while (and (not before) groupkey) @@ -706,6 +705,7 @@ nnoo-state-alist nil gnus-current-select-method nil nnmail-split-history nil + gnus-extended-servers nil gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. @@ -857,8 +857,7 @@ ;; it's not needed). ;; (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-set-mode-line)) (set-buffer obuf)))) @@ -871,10 +870,9 @@ (let ((dribble-file (gnus-dribble-file-name))) (unless (file-exists-p (file-name-directory dribble-file)) (make-directory (file-name-directory dribble-file) t)) - (save-excursion - (set-buffer (setq gnus-dribble-buffer - (gnus-get-buffer-create - (file-name-nondirectory dribble-file)))) + (with-current-buffer (setq gnus-dribble-buffer + (gnus-get-buffer-create + (file-name-nondirectory dribble-file))) (set (make-local-variable 'file-precious-flag) t) (erase-buffer) (setq buffer-file-name dribble-file) @@ -923,8 +921,7 @@ (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) + (with-current-buffer gnus-dribble-buffer (let ((auto (make-auto-save-file-name))) (when (file-exists-p auto) (delete-file auto)) @@ -934,14 +931,12 @@ (defun gnus-dribble-save () (when (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer)) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-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) + (with-current-buffer gnus-dribble-buffer (erase-buffer) (set-buffer-modified-p nil) (setq buffer-saved-size (buffer-size))))) @@ -1302,8 +1297,7 @@ (when (gnus-active group) (gnus-group-change-level group gnus-level-default-subscribed gnus-level-killed))) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer ;; Don't error if the group already exists. This happens when a ;; first-time user types 'F'. -- didier (gnus-group-make-help-group t)) @@ -1543,10 +1537,12 @@ t) (if (or debug-on-error debug-on-quit) (inline (gnus-request-group group (or dont-sub-check dont-check) - method)) + method + (gnus-get-info group))) (condition-case nil (inline (gnus-request-group group (or dont-sub-check dont-check) - method)) + method + (gnus-get-info group))) ;;(error nil) (quit (message "Quit activating %s" group) @@ -1692,34 +1688,25 @@ (gnus-agent-article-local-times 0) (archive-method (gnus-server-to-method "archive")) infos info group active method cmethod - method-type method-group-list) + method-type method-group-list entry) (gnus-message 6 "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. - - ;; To be more explicit: - ;; >0 for an active group with messages - ;; 0 for an active group with no unread messages - ;; nil for non-foreign groups that the user has requested not be checked - ;; t for unchecked foreign groups or bogus groups, or groups that can't - ;; be checked, for one reason or other. - ;; First go through all the groups, see what select methods they ;; belong to, and then collect them into lists per unique select ;; method. (if (not (setq method (gnus-info-method info))) (setq method gnus-select-method) + ;; There may be several similar methods. Possibly extend the + ;; method. (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) - (setq cmethod (inline (gnus-server-get-method nil method))) + (setq cmethod (if (stringp method) + (gnus-server-to-method method) + (inline (gnus-find-method-for-group + (gnus-info-group info) info)))) (push (cons method cmethod) methods-cache) (setq method cmethod))) (setq method-group-list (assoc method type-cache)) @@ -1734,15 +1721,21 @@ 'primary) (t 'foreign))) - (push (setq method-group-list (list method method-type nil)) + (push (setq method-group-list (list method method-type nil nil)) type-cache)) ;; Only add groups that need updating. - (when (<= (gnus-info-level info) - (if (eq (cadr method-group-list) 'foreign) - foreign-level - alevel)) - (setcar (nthcdr 2 method-group-list) - (cons info (nth 2 method-group-list))))) + (if (<= (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list))) + ;; The group is inactive, so we nix out the number of unread articles. + ;; It leads `(gnus-group-unread group)' to return t. See also + ;; `gnus-group-prepare-flat'. + (unless active + (when (setq entry (gnus-group-entry group)) + (setcar entry t))))) ;; Sort the methods based so that the primary and secondary ;; methods come first. This is done for legacy reasons to try to @@ -1754,19 +1747,31 @@ (< (gnus-method-rank (cadr c1) (car c1)) (gnus-method-rank (cadr c2) (car c2)))))) - (while type-cache - (setq method (nth 0 (car type-cache)) - method-type (nth 1 (car type-cache)) - infos (nth 2 (car type-cache))) - (pop type-cache) + ;; Start early async retrieval of data. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (when (and method infos + (not (gnus-method-denied-p method))) + (unless (gnus-server-opened method) + (gnus-open-server method)) + (when (gnus-check-backend-function + 'retrieve-group-data-early (car method)) + (when (gnus-check-backend-function 'request-scan (car method)) + (dolist (info infos) + (gnus-request-scan (gnus-info-group info) method))) + (setcar (nthcdr 3 elem) + (gnus-retrieve-group-data-early method infos)))))) - (when (and method - infos) - ;; See if any of the groups from this method require updating. - (gnus-read-active-for-groups method infos) - (dolist (info infos) - (inline (gnus-get-unread-articles-in-group - info (gnus-active (gnus-info-group info))))))) + ;; Do the rest of the retrieval. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos early-data) elem + (when (and method infos) + ;; See if any of the groups from this method require updating. + (gnus-read-active-for-groups method infos early-data) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info)) + t)))))) (gnus-message 6 "Checking new news...done"))) (defun gnus-method-rank (type method) @@ -1790,19 +1795,26 @@ (t 100))) -(defun gnus-read-active-for-groups (method infos) +(defun gnus-read-active-for-groups (method infos early-data) (with-current-buffer nntp-server-buffer (cond + ((and + (gnus-check-backend-function 'finish-retrieve-group-infos (car method)) + (or (not (gnus-agent-method-p method)) + (gnus-online method))) + (gnus-finish-retrieve-group-infos method infos early-data) + (gnus-agent-save-active method)) ((gnus-check-backend-function 'retrieve-groups (car method)) (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (gnus-read-active-file-2 - (mapcar (lambda (info) - (gnus-group-real-name (gnus-info-group info))) - infos) - method)) + (dolist (info infos) + (gnus-request-scan (gnus-info-group info) method))) + (let (groups) + (gnus-read-active-file-2 + (dolist (info infos (nreverse groups)) + (push (gnus-group-real-name (gnus-info-group info)) groups)) + method))) ((gnus-check-backend-function 'request-list (car method)) - (gnus-read-active-file-1 method nil)) + (gnus-read-active-file-1 method nil infos)) (t (dolist (info infos) (gnus-activate-group (gnus-info-group info) nil nil method t)))))) @@ -1860,8 +1872,7 @@ (defun gnus-parse-active () "Parse active info in the nntp server buffer." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-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]+") @@ -2015,8 +2026,7 @@ (list "archive"))))) method) (setq gnus-have-read-active-file nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while (setq method (pop methods)) ;; Only do each method once, in case the methods appear more ;; than once in this list. @@ -2031,20 +2041,24 @@ (message "Quit reading the active file") nil)))))))) -(defun gnus-read-active-file-1 (method force) +(defun gnus-read-active-file-1 (method force &optional infos) (let (where mesg) (setq 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) + (gnus-message 5 "%s" mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (and gnus-agent - (gnus-online method) + (when (and (or (and gnus-agent + (gnus-online method)) + (not gnus-agent)) (gnus-check-backend-function 'request-scan (car method))) - (gnus-request-scan nil method)) + (if infos + (dolist (info infos) + (gnus-request-scan (gnus-info-group info) method)) + (gnus-request-scan nil method))) (cond ((and (eq gnus-read-active-file 'some) (gnus-check-backend-function 'retrieve-groups (car method)) @@ -2069,7 +2083,7 @@ (unless (equal method gnus-message-archive-method) (gnus-error 1 "Cannot read active file from %s server" (car method))) - (gnus-message 5 mesg) + (gnus-message 5 "%s" mesg) (gnus-active-to-gnus-format method gnus-active-hashtb nil t) ;; We mark this active file as read. (push method gnus-have-read-active-file) @@ -2078,8 +2092,7 @@ (defun gnus-read-active-file-2 (groups method) "Read an active file for GROUPS in METHOD using `gnus-retrieve-groups'." (when groups - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (gnus-check-server method) (let ((list-type (gnus-retrieve-groups groups method))) (cond ((not list-type) @@ -2760,8 +2773,7 @@ (not force) (or (not gnus-dribble-buffer) (not (buffer-name gnus-dribble-buffer)) - (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) @@ -2895,8 +2907,7 @@ (defun gnus-gnus-to-newsrc-format () ;; Generate and save the .newsrc file. - (save-excursion - (set-buffer (create-file-buffer gnus-current-startup-file)) + (with-current-buffer (create-file-buffer gnus-current-startup-file) (let ((newsrc (cdr gnus-newsrc-alist)) (standard-output (current-buffer)) info ranges range method) @@ -2969,8 +2980,7 @@ (gnus-run-hooks 'gnus-slave-mode-hook)) (defun gnus-slave-save-newsrc () - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (let ((slave-name (mm-make-temp-file (concat gnus-current-startup-file "-slave-"))) (modes (ignore-errors @@ -2994,8 +3004,7 @@ (if (not slave-files) () ; There are no slave files to read. (gnus-message 7 "Reading slave newsrcs...") - (save-excursion - (set-buffer (gnus-get-buffer-create " *gnus slave*")) + (with-current-buffer (gnus-get-buffer-create " *gnus slave*") (setq slave-files (sort (mapcar (lambda (file) (list (nth 5 (file-attributes file)) file)) @@ -3115,8 +3124,7 @@ (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) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") (match-string 1)))))
--- a/lisp/gnus/gnus-sum.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-sum.el Wed Sep 22 15:46:51 2010 +0900 @@ -985,8 +985,7 @@ :group 'gnus-various :type 'hook) -(defcustom gnus-summary-update-hook - (list 'gnus-summary-highlight-line) +(defcustom gnus-summary-update-hook nil "*A hook called when a summary line is changed. The hook will not be called if `gnus-visual' is nil. @@ -3753,6 +3752,7 @@ (error (gnus-message 5 "Error updating the summary line"))) (when (gnus-visual-p 'summary-highlight 'highlight) (forward-line -1) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook) (forward-line 1)))) @@ -3785,6 +3785,7 @@ 'score)) ;; Do visual highlighting. (when (gnus-visual-p 'summary-highlight 'highlight) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook))))) (defvar gnus-tmp-new-adopts nil) @@ -5363,7 +5364,9 @@ 'gnus-number number) (when gnus-visual-p (forward-line -1) - (gnus-run-hooks 'gnus-summary-update-hook) + (gnus-summary-highlight-line) + (when gnus-summary-update-hook + (gnus-run-hooks 'gnus-summary-update-hook)) (forward-line 1)) (setq gnus-tmp-prev-subject simp-subject))) @@ -5501,11 +5504,11 @@ (mm-decode-coding-string (gnus-status-message group) charset)))) (unless (gnus-request-group group t) - (when (equal major-mode 'gnus-summary-mode) - (gnus-kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - (mm-decode-coding-string group charset) - (mm-decode-coding-string (gnus-status-message group) charset))) + (when (equal major-mode 'gnus-summary-mode) + (gnus-kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + (mm-decode-coding-string group charset) + (mm-decode-coding-string (gnus-status-message group) charset))) (when gnus-agent (gnus-agent-possibly-alter-active group (gnus-active group) info) @@ -5847,6 +5850,10 @@ (types gnus-article-mark-lists) marks var articles article mark mark-type bgn end) + ;; Hack to avoid adjusting marks for imap. + (when (eq (car (gnus-find-method-for-group (gnus-info-group info))) + 'nnimap) + (setq min 1)) (dolist (marks marked-lists) (setq mark (car marks) @@ -7327,7 +7334,7 @@ (defun gnus-summary-describe-briefly () "Describe summary mode commands briefly." (interactive) - (gnus-message 6 (substitute-command-keys "\\<gnus-summary-mode-map>\\[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"))) + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-summary-mode-map>\\[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. @@ -7391,7 +7398,7 @@ "Go to the first subject satisfying any non-nil constraint. If UNREAD is non-nil, the article should be unread. If UNDOWNLOADED is non-nil, the article should be undownloaded. -If UNSEEN is non-nil, the article should be unseen. +If UNSEEN is non-nil, the article should be unseen as well as unread. Returns the article selected or nil if there are no matching articles." (interactive "P") (cond @@ -7414,7 +7421,8 @@ (and undownloaded (memq num gnus-newsgroup-undownloaded)) (and unseen - (memq num gnus-newsgroup-unseen))))))) + (memq num gnus-newsgroup-unseen) + (memq num gnus-newsgroup-unreads))))))) (setq data (cdr data))) (prog1 (if data @@ -7905,8 +7913,8 @@ (gnus-summary-position-point))) (defun gnus-summary-first-unseen-or-unread-subject () - "Place the point on the subject line of the first unseen article or, -if all article have been seen, on the subject line of the first unread + "Place the point on the subject line of the first unseen and unread article. +If all article have been seen, on the subject line of the first unread article." (interactive) (prog1 @@ -9677,7 +9685,7 @@ gnus-newsgroup-name)) (to-method (or select-method (gnus-find-method-for-group to-newsgroup))) - (move-is-internal (gnus-method-equal from-method to-method))) + (move-is-internal (gnus-server-equal from-method to-method))) (gnus-request-move-article article ; Article to move gnus-newsgroup-name ; From newsgroup @@ -9687,7 +9695,9 @@ to-newsgroup (list 'quote select-method) (not articles) t) ; Accept form (not articles) ; Only save nov last time - move-is-internal))) ; is this move internal? + (and move-is-internal + to-newsgroup ; Not respooling + (gnus-group-real-name to-newsgroup))))) ; Is this move internal? ;; Copy the article. ((eq action 'copy) (with-current-buffer copy-buf @@ -9818,8 +9828,9 @@ (gnus-add-marked-articles to-group 'expire (list to-article) info)) - (gnus-request-set-mark - to-group (list (list (list to-article) 'add to-marks)))) + (when to-marks + (gnus-request-set-mark + to-group (list (list (list to-article) 'add to-marks))))) (gnus-dribble-enter (concat "(gnus-group-set-info '" @@ -10734,6 +10745,7 @@ (t gnus-no-mark)) 'replied) (when (gnus-visual-p 'summary-highlight 'highlight) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook)) t) @@ -10761,7 +10773,12 @@ ;; 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)) (char-after) mark) + (let ((to-insert + (mm-subst-char-in-string + (char-after) mark + (buffer-substring (point) (1+ (point)))))) + (delete-region (point) (1+ (point))) + (insert to-insert)) ;; Optionally update the marks by some user rule. (when (eq type 'unread) (gnus-data-set-mark
--- a/lisp/gnus/gnus-topic.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-topic.el Wed Sep 22 15:46:51 2010 +0900 @@ -148,8 +148,7 @@ (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) + (with-current-buffer gnus-group-buffer (if (gnus-group-goto-group group) (gnus-current-topic) (gnus-group-topic group)))) @@ -912,8 +911,7 @@ (defun gnus-topic-change-level (group level oldlevel &optional previous) "Run when changing levels to enter/remove groups from topics." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let ((buffer-read-only nil)) (unless gnus-topic-inhibit-change-level (gnus-group-goto-group (or (car (nth 2 previous)) group))
--- a/lisp/gnus/gnus-util.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-util.el Wed Sep 22 15:46:51 2010 +0900 @@ -1115,8 +1115,7 @@ (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) + (with-current-buffer file-buffer (if (fboundp 'rmail-insert-rmail-file-header) (rmail-insert-rmail-file-header)) (let ((require-final-newline nil) @@ -1194,8 +1193,7 @@ (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) + (with-current-buffer file-buffer (let ((require-final-newline nil) (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) @@ -1274,8 +1272,7 @@ "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) (get-buffer gnus-group-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) (defun gnus-remove-if (predicate list)
--- a/lisp/gnus/gnus-uu.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus-uu.el Wed Sep 22 15:46:51 2010 +0900 @@ -827,8 +827,7 @@ (defun gnus-uu-save-article (buffer in-state) (cond (gnus-uu-save-separate-articles - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer (concat gnus-uu-saved-article-name gnus-current-article))) @@ -838,8 +837,7 @@ ((eq in-state 'last) (list 'end)) (t (list 'middle))))) ((not gnus-uu-save-in-digest) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (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 @@ -857,11 +855,9 @@ (eq in-state 'first-and-last)) (progn (setq state (list 'begin)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus-uu-body*")) + (with-current-buffer (gnus-get-buffer-create "*gnus-uu-body*") (erase-buffer)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*")) + (with-current-buffer (gnus-get-buffer-create "*gnus-uu-pre*") (erase-buffer) (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\n" @@ -873,8 +869,7 @@ (insert "Topics:\n"))) (when (not (eq in-state 'end)) (setq state (list 'middle)))) - (save-excursion - (set-buffer "*gnus-uu-body*") + (with-current-buffer "*gnus-uu-body*" (goto-char (setq beg (point-max))) (save-excursion (save-restriction @@ -940,8 +935,7 @@ (when (re-search-forward "^Subject: \\(.*\\)$" nil t) (setq subj (buffer-substring (match-beginning 1) (match-end 1)))) (when subj - (save-excursion - (set-buffer "*gnus-uu-pre*") + (with-current-buffer "*gnus-uu-pre*" (insert (format " %s\n" subj))))) (when (or (eq in-state 'last) (eq in-state 'first-and-last)) @@ -951,8 +945,7 @@ (insert-buffer-substring "*gnus-uu-pre*") (goto-char (point-max)) (insert-buffer-substring "*gnus-uu-body*")) - (save-excursion - (set-buffer "*gnus-uu-pre*") + (with-current-buffer "*gnus-uu-pre*" (insert (format "\n\n%s\n\n" (make-string 70 ?-))) (if gnus-uu-digest-buffer (with-current-buffer gnus-uu-digest-buffer @@ -960,8 +953,7 @@ (insert-buffer-substring "*gnus-uu-pre*")) (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer gnus-uu-saved-article-name)))) - (save-excursion - (set-buffer "*gnus-uu-body*") + (with-current-buffer "*gnus-uu-body*" (goto-char (point-max)) (insert (concat (setq end-string (format "End of %s Digest" name)) @@ -993,8 +985,7 @@ (defun gnus-uu-binhex-article (buffer in-state) (let (state start-char) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (widen) (goto-char (point-min)) (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) @@ -1030,8 +1021,7 @@ ;; yEnc (defun gnus-uu-yenc-article (buffer in-state) - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (widen) (let ((file-name (yenc-extract-filename)) state start-char) @@ -1065,8 +1055,7 @@ (defun gnus-uu-decode-postscript-article (process-buffer in-state) (let ((state (list 'ok)) start-char end-char file-name) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (goto-char (point-min)) (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) (setq state (list 'wrong-type)) @@ -1128,8 +1117,7 @@ ;; replaces the last thing that looks like "2/3" with "[0-9]+/3" ;; or, if it can't find something like that, tries "2 of 3", then ;; finally just replaces the next to last number with "[0-9]+". - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (buffer-disable-undo) (erase-buffer) (insert (regexp-quote string)) @@ -1228,8 +1216,7 @@ ;; decoded in. Returns the list of expanded strings. (let ((out-list string-list) string) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (buffer-disable-undo) (while string-list (erase-buffer) @@ -1332,11 +1319,9 @@ (gnus-summary-display-article article) ;; Push the article to the processing function. - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (let ((buffer-read-only nil)) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (setq process-state (funcall process-function gnus-original-article-buffer state))))) @@ -1477,8 +1462,7 @@ (defun gnus-uu-uustrip-article (process-buffer in-state) ;; Uudecodes a file asynchronously. - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (let ((state (list 'wrong-type)) process-connection-type case-fold-search buffer-read-only files start-char) @@ -1600,8 +1584,7 @@ (defun gnus-uu-unshar-article (process-buffer in-state) (let ((state (list 'ok)) start-char) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (goto-char (point-min)) (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) (setq state (list 'wrong-type)) @@ -1688,8 +1671,7 @@ (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (erase-buffer)) (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) @@ -2039,9 +2021,8 @@ (setq file-name file-path)) (unwind-protect - (if (save-excursion - (set-buffer (setq uubuf - (gnus-get-buffer-create uuencode-buffer-name))) + (if (with-current-buffer + (setq uubuf (gnus-get-buffer-create uuencode-buffer-name)) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) (insert-buffer-substring uubuf) @@ -2073,8 +2054,8 @@ (setq beg-binary (point)) (setq end-binary (point-max)) - (save-excursion - (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name))) + (with-current-buffer + (setq uubuf (gnus-get-buffer-create encoded-buffer-name)) (erase-buffer) (insert-buffer-substring post-buf beg-binary end-binary) (goto-char (point-min)) @@ -2129,8 +2110,7 @@ (insert (format " (%d/%d)" i parts))) (goto-char (point-max)) - (save-excursion - (set-buffer uubuf) + (with-current-buffer uubuf (goto-char beg) (if (= i parts) (goto-char (point-max))
--- a/lisp/gnus/gnus.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/gnus.el Wed Sep 22 15:46:51 2010 +0900 @@ -2682,6 +2682,7 @@ (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) (defvar gnus-server-method-cache nil) +(defvar gnus-extended-servers nil) (defvar gnus-agent-fetching nil "Whether Gnus agent is in fetching mode.") @@ -2743,6 +2744,8 @@ '((seen range) (killed range) (bookmark tuple) + (uid tuple) + (active tuple) (score tuple))) ;; Propagate flags to server, with the following exceptions: @@ -3676,6 +3679,44 @@ gnus-valid-select-methods))) (equal (nth 1 m1) (nth 1 m2))))))) +(defun gnus-methods-sloppily-equal (m1 m2) + ;; Same method. + (or + (eq m1 m2) + ;; Type and name are equal. + (and + (eq (car m1) (car m2)) + (equal (cadr m1) (cadr m2)) + (gnus-sloppily-equal-method-parameters m1 m2)))) + +(defsubst gnus-sloppily-equal-method-parameters (m1 m2) + ;; Check parameters for sloppy equalness. + (let ((p1 (copy-list (cddr m1))) + (p2 (copy-list (cddr m2))) + e1 e2) + (block nil + (while (setq e1 (pop p1)) + (unless (setq e2 (assq (car e1) p2)) + ;; The parameter doesn't exist in p2. + (return nil)) + (setq p2 (delq e2 p2)) + (unless (equalp e1 e2) + (if (not (and (stringp (cadr e1)) + (stringp (cadr e2)))) + (return nil) + ;; Special-case string parameter comparison so that we + ;; can uniquify them. + (let ((s1 (cadr e1)) + (s2 (cadr e2))) + (when (string-match "/$" s1) + (setq s1 (directory-file-name s1))) + (when (string-match "/$" s2) + (setq s2 (directory-file-name s2))) + (unless (equal s1 s2) + (return nil)))))) + ;; If p2 now is empty, they were equal. + (null p2)))) + (defun gnus-server-equal (m1 m2) "Say whether two methods are equal." (let ((m1 (cond ((null m1) gnus-select-method) @@ -4140,13 +4181,19 @@ gnus-valid-select-methods))) (defun gnus-similar-server-opened (method) - (let ((opened gnus-opened-servers)) + "Return non-nil if we have a similar server opened. +This is defined as a server with the same name, but different +parameters." + (let ((opened gnus-opened-servers) + open) (while (and method opened) - (when (and (equal (cadr method) (cadaar opened)) - (equal (car method) (caaar opened)) - (not (equal method (caar opened)))) - (setq method nil)) - (pop opened)) + (setq open (car (pop opened))) + ;; Type and name are the same... + (when (and (equal (car method) (car open)) + (equal (cadr method) (cadr open)) + ;; ... but the rest of the parameters differ. + (not (gnus-methods-sloppily-equal method open))) + (setq method nil))) (not method))) (defun gnus-server-extend-method (group method) @@ -4157,9 +4204,12 @@ (if (or (not (inline (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)))) + (setq method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) + (push method gnus-extended-servers) + method)) (defun gnus-server-status (method) "Return the status of METHOD." @@ -4184,6 +4234,20 @@ (format "%s using %s" address (car server)) (format "%s" (car server))))) +(defun gnus-same-method-different-name (method) + (let ((slot (intern (concat (symbol-name (car method)) "-address")))) + (unless (assq slot (cddr method)) + (setq method + (append method (list (list slot (nth 1 method))))))) + (let ((methods gnus-extended-servers) + open found) + (while (and (not found) + (setq open (pop methods))) + (when (and (eq (car method) (car open)) + (gnus-sloppily-equal-method-parameters method open)) + (setq found open))) + found)) + (defun gnus-find-method-for-group (group &optional info) "Find the select method that GROUP uses." (or gnus-override-method @@ -4206,7 +4270,10 @@ (cond ((stringp method) (inline (gnus-server-to-method method))) ((stringp (cadr method)) - (inline (gnus-server-extend-method group method))) + (or + (inline + (gnus-same-method-different-name method)) + (inline (gnus-server-extend-method group method)))) (t method))) (cond ((equal (cadr method) "") @@ -4395,6 +4462,10 @@ 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") + ;; When using the development version of Gnus, load the gnus-load + ;; file. + (unless (string-match "^Gnus" gnus-version) + (load "gnus-load")) (unless (byte-code-function-p (symbol-function 'gnus)) (message "You should byte-compile Gnus") (sit-for 2))
--- a/lisp/gnus/mail-parse.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/mail-parse.el Wed Sep 22 15:46:51 2010 +0900 @@ -45,8 +45,7 @@ (defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) (defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) (defalias 'mail-content-type-get 'rfc2231-get-value) -;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) -(defalias 'mail-header-encode-parameter 'rfc2231-encode-string) +(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) (defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) (defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace)
--- a/lisp/gnus/mail-source.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/mail-source.el Wed Sep 22 15:46:51 2010 +0900 @@ -34,7 +34,7 @@ (require 'cl) (require 'imap)) (autoload 'auth-source-user-or-password "auth-source") -(autoload 'pop3-streaming-movemail "pop3") +(autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (autoload 'nnheader-cancel-timer "nnheader") (require 'mm-util) @@ -839,11 +839,9 @@ (if (eq authentication 'apop) 'apop 'pass)) (pop3-stream-type stream)) (if (or debug-on-quit debug-on-error) - (save-excursion (pop3-streaming-movemail - mail-source-crash-box)) + (save-excursion (pop3-movemail mail-source-crash-box)) (condition-case err - (save-excursion (pop3-streaming-movemail - mail-source-crash-box)) + (save-excursion (pop3-movemail mail-source-crash-box)) (error ;; We nix out the password in case the error ;; was because of a wrong password being given.
--- a/lisp/gnus/mm-decode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/mm-decode.el Wed Sep 22 15:46:51 2010 +0900 @@ -105,9 +105,7 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((and (executable-find "w3m") - (executable-find "curl")) - 'gnus-article-html) + (cond ((executable-find "w3m") 'gnus-article-html) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -116,6 +114,7 @@ "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: +`gnus-article-html' : use Gnus renderer based on w3m; `w3m' : use emacs-w3m; `w3m-standalone': use w3m; `links': use links; @@ -124,8 +123,9 @@ `html2text' : use html2text; nil : use external viewer (default web browser)." :version "24.1" - :type '(choice (const w3) - (const w3m :tag "emacs-w3m") + :type '(choice (const gnus-article-html) + (const w3) + (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) (const links) (const lynx)
--- a/lisp/gnus/mm-partial.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/mm-partial.el Wed Sep 22 15:46:51 2010 +0900 @@ -70,8 +70,7 @@ (sort (cons handle (mm-partial-find-parts id - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-article-number)))) #'(lambda (a b) (let ((anumber (string-to-number @@ -83,8 +82,7 @@ (< anumber bnumber))))) (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles phandles)) - (save-excursion - (set-buffer (generate-new-buffer " *mm*")) + (with-current-buffer (generate-new-buffer " *mm*") (while (setq phandle (pop phandles)) (setq nn (string-to-number (cdr (assq 'number
--- a/lisp/gnus/nnagent.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnagent.el Wed Sep 22 15:46:51 2010 +0900 @@ -190,9 +190,9 @@ (deffoo nnagent-request-expire-articles (articles group &optional server force) articles) -(deffoo nnagent-request-group (group &optional server dont-check) +(deffoo nnagent-request-group (group &optional server dont-check info) (nnoo-parent-function 'nnagent 'nnml-request-group - (list group (nnagent-server server) dont-check))) + (list group (nnagent-server server) dont-check info))) (deffoo nnagent-close-group (group &optional server) (nnoo-parent-function 'nnagent 'nnml-close-group @@ -252,6 +252,9 @@ (nnoo-parent-function 'nnagent 'nnml-request-regenerate (list (nnagent-server server)))) +(deffoo nnagent-retrieve-group-data-early (server infos) + nil) + ;; Use nnml functions for just about everything. (nnoo-import nnagent (nnml))
--- a/lisp/gnus/nnbabyl.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnbabyl.el Wed Sep 22 15:46:51 2010 +0900 @@ -75,8 +75,7 @@ (nnoo-define-basics nnbabyl) (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length articles)) (count 0) @@ -136,8 +135,7 @@ ;; Restore buffer mode. (when (and (nnbabyl-server-opened) nnbabyl-previous-buffer-mode) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (narrow-to-region (caar nnbabyl-previous-buffer-mode) (cdar nnbabyl-previous-buffer-mode)) @@ -155,8 +153,7 @@ (deffoo nnbabyl-request-article (article &optional newsgroup server buffer) (nnbabyl-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (when (search-forward (nnbabyl-article-string article) nil t) (let (start stop summary-line) @@ -194,7 +191,7 @@ (cons nnbabyl-current-group article) (nnbabyl-article-group-number))))))) -(deffoo nnbabyl-request-group (group &optional server dont-check) +(deffoo nnbabyl-request-group (group &optional server dont-check info) (let ((active (cadr (assoc group nnbabyl-group-alist)))) (save-excursion (cond @@ -216,8 +213,7 @@ (nnmail-get-new-mail 'nnbabyl (lambda () - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (save-buffer))) (file-name-directory nnbabyl-mbox-file) group @@ -264,8 +260,7 @@ rest) (nnmail-activate 'nnbabyl) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) @@ -308,8 +303,7 @@ result) (and (nnbabyl-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) (while (re-search-forward @@ -373,8 +367,7 @@ (deffoo nnbabyl-request-replace-article (article group buffer) (nnbabyl-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (if (not (search-forward (nnbabyl-article-string article) nil t)) nil @@ -388,8 +381,7 @@ ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) @@ -409,8 +401,7 @@ (deffoo nnbabyl-request-rename-group (group new-name &optional server) (nnbabyl-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -558,9 +549,8 @@ (defun nnbabyl-create-mbox () (unless (file-exists-p nnbabyl-mbox-file) ;; Create a new, empty RMAIL mbox file. - (save-excursion - (set-buffer (setq nnbabyl-mbox-buffer - (create-file-buffer nnbabyl-mbox-file))) + (with-current-buffer (setq nnbabyl-mbox-buffer + (create-file-buffer nnbabyl-mbox-file)) (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region @@ -572,8 +562,7 @@ (unless (and nnbabyl-mbox-buffer (buffer-name nnbabyl-mbox-buffer) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) ;; This buffer has changed since we read it last. Possibly. (save-excursion
--- a/lisp/gnus/nndiary.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nndiary.el Wed Sep 22 15:46:51 2010 +0900 @@ -380,8 +380,7 @@ (deffoo nndiary-retrieve-headers (sequence &optional group server fetch-old) (when (nndiary-possibly-change-directory group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((file nil) (number (length sequence)) @@ -483,7 +482,7 @@ (cons (if group-num (car group-num) group) (string-to-number (file-name-nondirectory path))))))) -(deffoo nndiary-request-group (group &optional server dont-check) +(deffoo nndiary-request-group (group &optional server dont-check info) (let ((file-name-coding-system nnmail-pathname-coding-system)) (cond ((not (nndiary-possibly-change-directory group server)) @@ -615,8 +614,7 @@ (let (nndiary-current-directory nndiary-current-group nndiary-article-file-alist) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) @@ -672,8 +670,7 @@ (deffoo nndiary-request-replace-article (article group buffer) (nndiary-possibly-change-directory group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (nndiary-possibly-create-directory group) (let ((chars (nnmail-insert-lines)) (art (concat (int-to-string article) "\t")) @@ -688,8 +685,7 @@ t) (setq headers (nndiary-parse-head chars article)) ;; Replace the NOV line in the NOV file. - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (goto-char (point-min)) (if (or (looking-at art) (search-forward (concat "\n" art) nil t)) @@ -842,8 +838,7 @@ ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (save-excursion - (set-buffer (get-buffer-create " *nndiary id*")) + (with-current-buffer (get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -888,8 +883,7 @@ (let ((nov (expand-file-name nndiary-nov-file-name nndiary-current-directory))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -989,8 +983,7 @@ (defun nndiary-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -1015,8 +1008,7 @@ (or (cdr (assoc group nndiary-nov-buffer-alist)) (let ((buffer (get-buffer-create (format " *nndiary overview %s*" group)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name nndiary-nov-file-name @@ -1103,9 +1095,8 @@ (nov (concat dir nndiary-nov-file-name)) (nov-buffer (get-buffer-create " *nov*")) chars file headers) - (save-excursion - ;; Init the nov buffer. - (set-buffer nov-buffer) + ;; Init the nov buffer. + (with-current-buffer nov-buffer (buffer-disable-undo) (erase-buffer) (set-buffer nntp-server-buffer) @@ -1125,20 +1116,17 @@ (unless (zerop (buffer-size)) (goto-char (point-min)) (setq headers (nndiary-parse-head chars (caar files))) - (save-excursion - (set-buffer nov-buffer) + (with-current-buffer nov-buffer (goto-char (point-max)) (nnheader-insert-nov headers))) (widen)) (setq files (cdr files))) - (save-excursion - (set-buffer nov-buffer) + (with-current-buffer nov-buffer (nnmail-write-region 1 (point-max) nov nil 'nomesg) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point))) (when (bobp)
--- a/lisp/gnus/nndoc.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nndoc.el Wed Sep 22 15:46:51 2010 +0900 @@ -215,8 +215,7 @@ (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nndoc-possibly-change-buffer newsgroup server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article entry) (if (stringp (car articles)) @@ -265,7 +264,7 @@ (funcall nndoc-article-transform-function article)) t)))))) -(deffoo nndoc-request-group (group &optional server dont-check) +(deffoo nndoc-request-group (group &optional server dont-check info) "Select news GROUP." (let (number) (cond @@ -333,8 +332,7 @@ (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (erase-buffer) (if (and (stringp nndoc-address) (string-match nndoc-binary-file-names nndoc-address)) @@ -347,8 +345,7 @@ ;; Initialize the nndoc structures according to this new document. (when (and nndoc-current-buffer (not nndoc-dissection-alist)) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (nndoc-set-delims) (if (eq nndoc-article-type 'mime-parts) (nndoc-dissect-mime-parts) @@ -588,8 +585,7 @@ (defun nndoc-generate-clari-briefs-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) subject from) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (save-restriction (narrow-to-region (car entry) (nth 3 entry)) (goto-char (point-min)) @@ -677,8 +673,7 @@ (let ((entry (cdr (assq article nndoc-dissection-alist))) (from "<no address given>") subject date) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (save-restriction (narrow-to-region (car entry) (nth 1 entry)) (goto-char (point-min)) @@ -829,8 +824,7 @@ (first t) art-begin head-begin head-end body-begin body-end) (setq nndoc-dissection-alist nil) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (goto-char (point-min)) ;; Remove blank lines. (while (eq (following-char) ?\n) @@ -902,8 +896,7 @@ the header of this entity, and one article per sub-entity." (setq nndoc-dissection-alist nil nndoc-mime-split-ordinal 0) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil))) (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
--- a/lisp/gnus/nndraft.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nndraft.el Wed Sep 22 15:46:51 2010 +0900 @@ -77,8 +77,7 @@ (deffoo nndraft-retrieve-headers (articles &optional group server fetch-old) (nndraft-possibly-change-group group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* (article) ;; We don't support fetching by Message-ID. @@ -119,8 +118,7 @@ mm-text-coding-system) mm-auto-save-coding-system))) (nnmail-find-file newest))) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) ;; If there's a mail header separator in this file, ;; we remove it. @@ -184,7 +182,7 @@ (add-hook hook 'nndraft-generate-headers nil t)) article)) -(deffoo nndraft-request-group (group &optional server dont-check) +(deffoo nndraft-request-group (group &optional server dont-check info) (nndraft-possibly-change-group group) (unless dont-check (let* ((pathname (nnmail-group-pathname group nndraft-directory)) @@ -209,8 +207,7 @@ result) (and (nndraft-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form))
--- a/lisp/gnus/nneething.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nneething.el Wed Sep 22 15:46:51 2010 +0900 @@ -81,8 +81,7 @@ (deffoo nneething-retrieve-headers (articles &optional group server fetch-old) (nneething-possibly-change-directory group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((number (length articles)) (count 0) @@ -145,7 +144,7 @@ (insert "\n")) t)))) -(deffoo nneething-request-group (group &optional server dont-check) +(deffoo nneething-request-group (group &optional server dont-check info) (nneething-possibly-change-directory group server) (unless dont-check (nneething-create-mapping) @@ -323,8 +322,7 @@ (if (equal '(0 0) (nth 5 atts)) "" (concat "Date: " (current-time-string (nth 5 atts)) "\n")) (or (when buffer - (save-excursion - (set-buffer buffer) + (with-current-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)) @@ -332,8 +330,7 @@ (concat "Chars: " (int-to-string (nth 7 atts)) "\n") "") (if buffer - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (concat "Lines: " (int-to-string (count-lines (point-min) (point-max))) "\n")) @@ -382,8 +379,7 @@ (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (save-excursion - (set-buffer (get-buffer-create nneething-work-buffer)) + (with-current-buffer (get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer)
--- a/lisp/gnus/nnfolder.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnfolder.el Wed Sep 22 15:46:51 2010 +0900 @@ -157,8 +157,7 @@ (nnoo-define-basics nnfolder) (deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article start stop num) (nnfolder-possibly-change-group group server) @@ -261,8 +260,7 @@ (deffoo nnfolder-request-article (article &optional group server buffer) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (when (nnfolder-goto-article article) (let (start stop) @@ -291,7 +289,7 @@ (point) (point-at-eol))) -1)))))))) -(deffoo nnfolder-request-group (group &optional server dont-check) +(deffoo nnfolder-request-group (group &optional server dont-check info) (nnfolder-possibly-change-group group server t) (save-excursion (cond ((not (assoc group nnfolder-group-alist)) @@ -360,8 +358,7 @@ nnfolder-current-group (car inf)))) (when (and nnfolder-current-buffer (buffer-name nnfolder-current-buffer)) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; If the buffer was modified, write the file out now. (nnfolder-save-buffer) ;; If we're shutting the server down, we need to kill the @@ -447,8 +444,7 @@ target) (nnmail-activate 'nnfolder) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; Since messages are sorted in arrival order and expired in the ;; same order, we can stop as soon as we find a message that is ;; too old. @@ -501,8 +497,7 @@ result) (and (nnfolder-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) @@ -578,8 +573,7 @@ (deffoo nnfolder-request-replace-article (article group buffer) (nnfolder-possibly-change-group group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char (point-min)) (if (not (looking-at "X-From-Line: ")) (insert "From nobody " (current-time-string) "\n") @@ -596,8 +590,7 @@ (nnfolder-delete-mail) (insert-buffer-substring buffer) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (let ((headers (nnfolder-parse-head article (point-min) (point-max)))) (with-current-buffer (nnfolder-open-nov group) @@ -630,8 +623,7 @@ (deffoo nnfolder-request-rename-group (group new-name &optional server) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (and (file-writable-p buffer-file-name) (ignore-errors (let ((new-file (nnfolder-group-pathname new-name))) @@ -671,8 +663,7 @@ (marker (concat "\n" nnfolder-article-marker)) (number "[0-9]+") (activemin (cdr active))) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (while (and (search-forward marker nil t) (re-search-forward number nil t)) @@ -1114,8 +1105,7 @@ (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) (erase-buffer) @@ -1139,8 +1129,7 @@ (setq nnfolder-nov-buffer-alist (cdr nnfolder-nov-buffer-alist))))) (defun nnfolder-nov-delete-article (group article) - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point)))) t)) @@ -1150,8 +1139,7 @@ nil (let ((nov (nnfolder-group-nov-pathname nnfolder-current-group))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -1187,8 +1175,7 @@ (defun nnfolder-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers)))
--- a/lisp/gnus/nnheader.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnheader.el Wed Sep 22 15:46:51 2010 +0900 @@ -463,7 +463,7 @@ (let ((extra (mail-header-extra header))) (while extra (insert (symbol-name (caar extra)) - ": " (cdar extra) "\t") + ": " (if (stringp (cdar extra)) (cdar extra) "") "\t") (pop extra)))) (insert "\n") (backward-char 1) @@ -835,8 +835,7 @@ "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 - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if (string-match "%" format) (insert (apply 'format format args))
--- a/lisp/gnus/nnimap.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnimap.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,11 +1,9 @@ -;;; nnimap.el --- imap backend for Gnus +;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010 Free Software Foundation, Inc. -;; Author: Simon Josefsson <simon@josefsson.org> -;; Jim Radford <radford@robby.caltech.edu> -;; Keywords: mail +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Simon Josefsson <simon@josefsson.org> ;; This file is part of GNU Emacs. @@ -24,1791 +22,1173 @@ ;;; Commentary: -;; Todo, major things: -;; -;; o Fix Gnus to view correct number of unread/total articles in group buffer -;; o Fix Gnus to handle leading '.' in group names (fixed?) -;; o Finish disconnected mode (moving articles between mailboxes unplugged) -;; o Sieve -;; o MIME (partial article fetches) -;; o Split to other backends, different split rules for different -;; servers/inboxes -;; -;; Todo, minor things: -;; -;; o Don't require half of Gnus -- backends should be standalone -;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B) -;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow) -;; o Split up big fetches (1,* header especially) in smaller chunks -;; o What do I do with gnus-newsgroup-*? -;; o Tell Gnus about new groups (how can we tell?) -;; o Respooling (fix Gnus?) (unnecessary?) -;; o Add support for the following: (if applicable) -;; request-list-newsgroups, request-regenerate -;; list-active-group, -;; request-associate-buffer, request-restore-buffer, -;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?) -;; o Support RFC2221 (Login referrals) -;; o IMAP2BIS compatibility? (RFC2061) -;; o ACAP stuff (perhaps a different project, would be nice to ACAPify -;; .newsrc.eld) -;; o What about Gnus's article editing, can we support it? NO! -;; o Use \Draft to support the draft group?? -;; o Duplicate suppression -;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers +;; nnimap interfaces Gnus with IMAP servers. ;;; Code: -;; For Emacs < 22.2. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'nnheader)) -(require 'imap) -(require 'nnoo) -(require 'nnmail) +(eval-when-compile + (require 'cl)) + (require 'nnheader) -(require 'mm-util) +(require 'gnus-util) (require 'gnus) -(require 'gnus-range) -(require 'gnus-start) -(require 'gnus-int) - -(eval-when-compile (require 'cl)) - -(autoload 'auth-source-user-or-password "auth-source") +(require 'nnoo) +(require 'netrc) +(require 'parse-time) (nnoo-declare nnimap) -(defconst nnimap-version "nnimap 1.0") - -(defgroup nnimap nil - "Reading IMAP mail with Gnus." - :group 'gnus) - (defvoo nnimap-address nil - "Address of physical IMAP server. If nil, use the virtual server's name.") + "The address of the IMAP server.") (defvoo nnimap-server-port nil - "Port number on physical IMAP server. -If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") - -;; Splitting variables - -(defcustom nnimap-split-crosspost t - "If non-nil, do crossposting if several split methods match the mail. -If nil, the first match found will be used." - :group 'nnimap - :type 'boolean) + "The IMAP port used. +If nnimap-stream is `ssl', this will default to `imaps'. If not, +it will default to `imap'.") -(defcustom nnimap-split-inbox nil - "Name of mailbox to split mail from. - -Mail is read from this mailbox and split according to rules in -`nnimap-split-rule'. - -This can be a string or a list of strings." - :group 'nnimap - :type '(choice (string) - (repeat string))) - -(define-widget 'nnimap-strict-function 'function - "This widget only matches values that are functionp. +(defvoo nnimap-stream 'ssl + "How nnimap will talk to the IMAP server. +Values are `ssl' and `network'.") -Warning: This means that a value that is the symbol of a not yet -loaded function will not match. Use with care." - :match 'nnimap-strict-function-match) - -(defun nnimap-strict-function-match (widget value) - "Ignoring WIDGET, match if VALUE is a function." - (functionp value)) - -(defcustom nnimap-split-rule nil - "Mail will be split according to these rules. - -Mail is read from mailbox(es) specified in `nnimap-split-inbox'. +(defvoo nnimap-shell-program (if (boundp 'imap-shell-program) + (if (listp imap-shell-program) + (car imap-shell-program) + imap-shell-program) + "ssh %s imapd")) -If you'd like, for instance, one mail group for mail from the -\"gnus-imap\" mailing list, one group for junk mail and leave -everything else in the incoming mailbox, you could do something like -this: - -\(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") - (\"INBOX.junk\" \"Subject:.*buy\"))) - -As you can see, `nnimap-split-rule' is a list of lists, where the -first element in each \"rule\" is the name of the IMAP mailbox (or the -symbol `junk' if you want to remove the mail), and the second is a -regexp that nnimap will try to match on the header to find a fit. - -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-nil value if it thinks that the -mail belongs in that group. +(defvoo nnimap-inbox nil + "The mail box where incoming mail arrives and should be split out of.") -This variable can also have a function as its value, the function will -be called with the headers narrowed and should return a group where it -thinks the article should be splitted to. See `nnimap-split-fancy'. +(defvoo nnimap-expunge-inbox nil + "If non-nil, expunge the inbox after fetching mail. +This is always done if the server supports UID EXPUNGE, but it's +not done by default on servers that doesn't support that command.") -To allow for different split rules on different virtual servers, and -even different split rules in different inboxes on the same server, -the syntax of this variable have been extended along the lines of: - -\(setq nnimap-split-rule - '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\") - (\"junk\" \"From:.*Simon\"))) - (\"my2server\" (\"INBOX\" nnimap-split-fancy)) - (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") - (\"junk\" my-junk-func))))) +(defvoo nnimap-authenticator nil + "How nnimap authenticate itself to the server. +Possible choices are nil (use default methods) or `anonymous'.") -The virtual server name is in fact a regexp, so that the same rules -may apply to several servers. In the example, the servers -\"my3server\" and \"my4server\" both use the same rules. Similarly, -the inbox string is also a regexp. The actual splitting rules are as -before, either a function, or a list with group/regexp or -group/function elements." - :group 'nnimap - ;; FIXME: Doesn't allow `("my2server" ("INBOX" nnimap-split-fancy))' - ;; per example above. -- fx - :type '(choice :tag "Rule type" - (repeat :menu-tag "Single-server" - :tag "Single-server list" - (list (string :tag "Mailbox") - (choice :tag "Predicate" - (regexp :tag "A regexp") - (nnimap-strict-function :tag "A function")))) - (choice :menu-tag "A function" - :tag "A function" - (function-item nnimap-split-fancy) - (function-item nnmail-split-fancy) - (nnimap-strict-function :tag "User-defined function")) - (repeat :menu-tag "Multi-server (extended)" - :tag "Multi-server list" - (list (regexp :tag "Server regexp") - (list (regexp :tag "Incoming Mailbox regexp") - (repeat :tag "Rules for matching server(s) and mailbox(es)" - (list (string :tag "Destination mailbox") - (choice :tag "Predicate" - (regexp :tag "A Regexp") - (nnimap-strict-function :tag "A Function"))))))))) +(defvoo nnimap-fetch-partial-articles nil + "If non-nil, nnimap will fetch partial articles. +If t, nnimap will fetch only the first part. If a string, it +will fetch all parts that have types that match that string. A +likely value would be \"text/\" to automatically fetch all +textual parts.") -(defcustom nnimap-split-predicate "UNSEEN UNDELETED" - "The predicate used to find articles to split. -If you use another IMAP client to peek on articles but always would -like nnimap to split them once it's started, you could change this to -\"UNDELETED\". Other available predicates are available in -RFC2060 section 6.4.4." - :group 'nnimap - :type 'string) +(defvoo nnimap-expunge nil) + +(defvoo nnimap-connection-alist nil) -(defcustom nnimap-split-fancy nil - "Like the variable `nnmail-split-fancy'." - :group 'nnimap - :type 'sexp) +(defvoo nnimap-current-infos nil) + +(defvar nnimap-process nil) + +(defvar nnimap-status-string "") (defvar nnimap-split-download-body-default nil "Internal variable with default value for `nnimap-split-download-body'.") -(defcustom nnimap-split-download-body 'default - "Whether to download entire articles during splitting. -This is generally not required, and will slow things down considerably. -You may need it if you want to use an advanced splitting function that -analyzes the body before splitting the article. -If this variable is nil, bodies will not be downloaded; if this -variable is the symbol `default' the default behavior is -used (which currently is nil, unless you use a statistical -spam.el test); if this variable is another non-nil value bodies -will be downloaded." - :version "22.1" - :group 'nnimap - :type '(choice (const :tag "Let system decide" deault) - boolean)) - -;; Performance / bug workaround variables - -(defcustom nnimap-close-asynchronous t - "Close mailboxes asynchronously in `nnimap-close-group'. -This means that errors caught by nnimap when closing the mailbox will -not prevent Gnus from updating the group status, which may be harmful. -However, it increases speed." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defcustom nnimap-dont-close t - "Never close mailboxes. -This increases the speed of closing mailboxes (quiting group) but may -decrease the speed of selecting another mailbox later. Re-selecting -the same mailbox will be faster though." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defcustom nnimap-retrieve-groups-asynchronous t - "Send asynchronous STATUS commands for each mailbox before checking mail. -If you have mailboxes that rarely receives mail, this speeds up new -mail checking. It works by first sending STATUS commands for each -mailbox, and then only checking groups which has a modified UIDNEXT -more carefully for new mail. - -In summary, the default is O((1-p)*k+p*n) and changing it to nil makes -it O(n). If p is small, then the default is probably faster." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defvoo nnimap-need-unselect-to-notice-new-mail t - "Unselect mailboxes before looking for new mail in them. -Some servers seem to need this under some circumstances.") - -(defvoo nnimap-logout-timeout nil - "Close server immediately if it can't logout in this number of seconds. -If it is nil, never close server until logout completes. This variable -overrides `imap-logout-timeout' on a per-server basis.") - -;; Authorization / Privacy variables - -(defvoo nnimap-auth-method nil - "Obsolete.") - -(defvoo nnimap-stream nil - "How nnimap will connect to the server. - -The default, nil, will try to use the \"best\" method the server can -handle. - -Change this if - -1) you want to connect with TLS/SSL. The TLS/SSL integration - with IMAP is suboptimal so you'll have to tell it - specifically. - -2) your server is more capable than your environment -- i.e. your - server accept Kerberos login's but you haven't installed the - `imtest' program or your machine isn't configured for Kerberos. - -Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell. -See also `imap-streams' and `imap-stream-alist'.") - -(defvoo nnimap-authenticator nil - "How nnimap authenticate itself to the server. - -The default, nil, will try to use the \"best\" method the server can -handle. - -There is only one reason for fiddling with this variable, and that is -if your server is more capable than your environment -- i.e. you -connect to a server that accept Kerberos login's but you haven't -installed the `imtest' program or your machine isn't configured for -Kerberos. - -Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous. -See also `imap-authenticators' and `imap-authenticator-alist'") - -(defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") - "Directory to keep NOV cache files for nnimap groups. -See also `nnimap-nov-file-name'.") - -(defvoo nnimap-nov-file-name "nnimap." - "NOV cache base filename. -The group name and `nnimap-nov-file-name-suffix' will be appended. A -typical complete file name would be -~/News/overview/nnimap.pdc.INBOX.ding.nov, or -~/News/overview/nnimap/pdc/INBOX/ding/nov if -`nnmail-use-long-file-names' is nil") - -(defvoo nnimap-nov-file-name-suffix ".novcache" - "Suffix for NOV cache base filename.") - -(defvoo nnimap-nov-is-evil gnus-agent - "If non-nil, never generate or use a local nov database for this backend. -Using nov databases should speed up header fetching considerably. -However, it will invoke a UID SEARCH UID command on the server, and -some servers implement this command inefficiently by opening each and -every message in the group, thus making it quite slow. -Unlike other backends, you do not need to take special care if you -flip this variable.") - -(defvoo nnimap-search-uids-not-since-is-evil nil - "If non-nil, avoid \"UID SEARCH UID ... NOT SINCE\" queries when expiring. -Instead, use \"UID SEARCH SINCE\" to prune the list of expirable -articles within Gnus. This seems to be faster on Courier in some cases.") - -(defvoo nnimap-expunge-on-close 'always ; 'ask, 'never - "Whether to expunge a group when it is closed. -When a IMAP group with articles marked for deletion is closed, this -variable determine if nnimap should actually remove the articles or -not. - -If always, nnimap always perform a expunge when closing the group. -If never, nnimap never expunges articles marked for deletion. -If ask, nnimap will ask you if you wish to expunge marked articles. +(defstruct nnimap + group process commands capabilities select-result newlinep) -When setting this variable to `never', you can only expunge articles -by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.") - -(defvoo nnimap-list-pattern "*" - "A string LIMIT or list of strings with mailbox wildcards used to limit available groups. -See below for available wildcards. - -The LIMIT string can be a cons cell (REFERENCE . LIMIT), where -REFERENCE will be passed as the first parameter to LIST/LSUB. The -semantics of this are server specific, on the University of Washington -server you can specify a directory. - -Example: - '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\")) - -There are two wildcards * and %. * matches everything, % matches -everything in the current hierarchy.") - -(defvoo nnimap-news-groups nil - "IMAP support a news-like mode, also known as bulletin board mode, -where replies is sent via IMAP instead of SMTP. - -This variable should contain a regexp matching groups where you wish -replies to be stored to the mailbox directly. - -Example: - '(\"^[^I][^N][^B][^O][^X].*$\") - -This will match all groups not beginning with \"INBOX\". - -Note that there is nothing technically different between mail-like and -news-like mailboxes. If you wish to have a group with todo items or -similar which you wouldn't want to set up a mailing list for, you can -use this to make replies go directly to the group.") - -(defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s" - "IMAP search command to use for articles that are to be expired. -The first %s is replaced by a UID set of articles to search on, -and the second %s is replaced by a date criterium. - -One useful (and perhaps the only useful) value to change this to would -be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header -instead of the internal date of messages. See section 6.4.4 of RFC -2060 for more information on valid strings. - -However, if `nnimap-search-uids-not-since-is-evil' is true, this -variable has no effect since the search logic is reversed.") - -(defvoo nnimap-importantize-dormant t - "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients. -Note that within Gnus, dormant articles will still (only) be -marked as ticked. This is to make \"dormant\" articles stand out, -just like \"ticked\" articles, in other IMAP clients.") - -(defvoo nnimap-server-address nil - "Obsolete. Use `nnimap-address'.") - -(defcustom nnimap-authinfo-file "~/.authinfo" - "Authorization information for IMAP servers. In .netrc format." - :type - '(choice file - (repeat :tag "Entries" - :menu-tag "Inline" - (list :format "%v" - :value ("" ("login" . "") ("password" . "")) - (string :tag "Host") - (checklist :inline t - (cons :format "%v" - (const :format "" "login") - (string :format "Login: %v")) - (cons :format "%v" - (const :format "" "password") - (string :format "Password: %v")))))) - :group 'nnimap) - -(defcustom nnimap-prune-cache t - "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." - :type 'boolean - :group 'nnimap) - -(defvar nnimap-request-list-method 'imap-mailbox-list - "Method to use to request a list of all folders from the server. -If this is 'imap-mailbox-lsub, then use a server-side subscription list to -restrict visible folders.") - -(defcustom nnimap-id nil - "Plist with client identity to send to server upon login. -A nil value means no information is sent, symbol `no' to disable ID query -altogether, or plist with identifier-value pairs to send to -server. RFC 2971 describes the list as follows: - - Any string may be sent as a field, but the following are defined to - describe certain values that might be sent. Implementations are free - to send none, any, or all of these. Strings are not case-sensitive. - Field strings MUST NOT be longer than 30 octets. Value strings MUST - NOT be longer than 1024 octets. Implementations MUST NOT send more - than 30 field-value pairs. - - name Name of the program - version Version number of the program - os Name of the operating system - os-version Version of the operating system - vendor Vendor of the client/server - support-url URL to contact for support - address Postal address of contact/vendor - date Date program was released, specified as a date-time - in IMAP4rev1 - command Command used to start the program - arguments Arguments supplied on the command line, if any - if any - environment Description of environment, i.e., UNIX environment - variables or Windows registry settings - - Implementations MUST NOT send the same field name more than once. - -An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number -\"os\" system-configuration \"vendor\" \"GNU\")." - :group 'nnimap - :type '(choice (const :tag "No information" nil) - (const :tag "Disable ID query" no) - (plist :key-type string :value-type string))) - -(defcustom nnimap-debug nil - "If non-nil, trace nnimap- functions into `nnimap-debug-buffer'. -Uses `trace-function-background', so you can turn it off with, -say, `untrace-all'. - -Note that username, passwords and other privacy sensitive -information (such as e-mail) may be stored in the buffer. -It is not written to disk, however. Do not enable this -variable unless you are comfortable with that. - -This variable only takes effect when loading the `nnimap' library. -See also `nnimap-log'." - :group 'nnimap - :type 'boolean) - -;; Internal variables: +(defvar nnimap-object nil) -(defvar nnimap-debug-buffer "*nnimap-debug*") -(defvar nnimap-mailbox-info (gnus-make-hashtable 997)) -(defvar nnimap-current-move-server nil) -(defvar nnimap-current-move-group nil) -(defvar nnimap-current-move-article nil) -(defvar nnimap-length) -(defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) -(defvar nnimap-progress-how-often 20) -(defvar nnimap-counter) -(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. -(defvar nnimap-current-server nil) ;; Current server -(defvar nnimap-server-buffer nil) ;; Current servers' buffer - - - -(nnoo-define-basics nnimap) - -;; Utility functions: - -(defsubst nnimap-decode-group-name (group) - (and group - (gnus-group-decoded-name group))) - -(defsubst nnimap-encode-group-name (group) - (and group - (mm-encode-coding-string group (gnus-group-name-charset nil group)))) - -(defun nnimap-group-prefixed-name (group &optional server) - (gnus-group-prefixed-name group - (gnus-server-to-method - (format "nnimap:%s" - (or server nnimap-current-server))))) - -(defsubst nnimap-get-server-buffer (server) - "Return buffer for SERVER, if nil use current server." - (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) - -(defun nnimap-remove-server-from-buffer-alist (server list) - "Remove SERVER from LIST." - (let (l) - (dolist (e list) - (unless (equal server (car-safe e)) - (push e l))) - l)) - -(defun nnimap-possibly-change-server (server) - "Return buffer for SERVER, changing the current server as a side-effect. -If SERVER is nil, uses the current server." - (setq nnimap-current-server (or server nnimap-current-server) - nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server))) - -(defun nnimap-verify-uidvalidity (group server) - "Verify stored uidvalidity match current one in GROUP on SERVER." - (let* ((gnusgroup (nnimap-group-prefixed-name group server)) - (new-uidvalidity (imap-mailbox-get 'uidvalidity)) - (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)) - (dir (file-name-as-directory (expand-file-name nnimap-directory))) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." old-uidvalidity - nnimap-nov-file-name-suffix) t)) - (file (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name nameuid dir))) - (expand-file-name nameuid dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string nameuid ?. ?/) - nnmail-pathname-coding-system) - dir)))) - (if old-uidvalidity - (if (not (equal old-uidvalidity new-uidvalidity)) - ;; uidvalidity clash - (progn - (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) - (gnus-group-remove-parameter gnusgroup 'imap-status) - (gnus-sethash (gnus-group-prefixed-name group server) - nil nnimap-mailbox-info) - (gnus-delete-file file)) - t) - (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) - (gnus-group-remove-parameter gnusgroup 'imap-status) - (gnus-sethash ; Maybe not necessary here. - (gnus-group-prefixed-name group server) - nil nnimap-mailbox-info) - t))) - -(defun nnimap-before-find-minmax-bugworkaround () - "Function called before iterating through mailboxes with -`nnimap-find-minmax-uid'." - (when nnimap-need-unselect-to-notice-new-mail - ;; XXX this is for UoW imapd problem, it doesn't notice new mail in - ;; currently selected mailbox without a re-select/examine. - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)))) - -(defun nnimap-find-minmax-uid (group &optional examine) - "Find lowest and highest active article number in GROUP. -If EXAMINE is non-nil the group is selected read-only." - (with-current-buffer nnimap-server-buffer - (let ((decoded-group (nnimap-decode-group-name group))) - (when (or (string= decoded-group (imap-current-mailbox)) - (imap-mailbox-select decoded-group examine)) - (let (minuid maxuid) - (when (> (imap-mailbox-get 'exists) 0) - (imap-fetch "1:*" "UID" nil 'nouidfetch) - (imap-message-map - (lambda (uid Uid) - (setq minuid (if minuid (min minuid uid) uid) - maxuid (if maxuid (max maxuid uid) uid))) - 'UID)) - (list (imap-mailbox-get 'exists) minuid maxuid)))))) - -(defun nnimap-possibly-change-group (group &optional server) - "Make GROUP the current group, and SERVER the current server." - (when (nnimap-possibly-change-server server) - (let ((decoded-group (nnimap-decode-group-name group))) - (with-current-buffer nnimap-server-buffer - (if (or (null group) (imap-current-mailbox-p decoded-group)) - imap-current-mailbox ; Note: utf-7 encoded. - (if (imap-mailbox-select decoded-group) - (if (or (nnimap-verify-uidvalidity - group (or server nnimap-current-server)) - (zerop (imap-mailbox-get 'exists decoded-group)) - t ;; for OGnus to see if ignoring uidvalidity - ;; changes has any bad effects. - (yes-or-no-p - (format - "nnimap: Group %s is not uidvalid. Continue? " - decoded-group))) - imap-current-mailbox ; Note: utf-7 encoded. - (imap-mailbox-unselect) - (error "nnimap: Group %s is not uid-valid" decoded-group)) - (nnheader-report 'nnimap (imap-error-text)))))))) - -(defun nnimap-replace-whitespace (string) - "Return STRING with all whitespace replaced with space." - (when string - (while (string-match "[\r\n\t]+" string) - (setq string (replace-match " " t t string))) - string)) - -;; Required backend functions +(defvar nnimap-mark-alist + '((read "\\Seen") + (tick "\\Flagged") + (reply "\\Answered") + (expire "gnus-expire") + (dormant "gnus-dormant") + (score "gnus-score") + (save "gnus-save") + (download "gnus-download") + (forward "gnus-forward"))) -(defun nnimap-retrieve-headers-progress () - "Hook to insert NOV line for current article into `nntp-server-buffer'." - (and (numberp nnmail-large-newsgroup) - (zerop (% (incf nnimap-counter) nnimap-progress-how-often)) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers... %c" - (nth (/ (% nnimap-counter - (* (length nnimap-progress-chars) - nnimap-progress-how-often)) - nnimap-progress-how-often) - nnimap-progress-chars))) - (with-current-buffer nntp-server-buffer - (let (headers lines chars uid mbx) - (with-current-buffer nnimap-server-buffer - (setq uid imap-current-message - mbx (nnimap-encode-group-name (imap-current-mailbox)) - headers (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get uid 'BODYDETAIL))) - (imap-message-get uid 'RFC822.HEADER)) - lines (imap-body-lines (imap-message-body imap-current-message)) - chars (imap-message-get imap-current-message 'RFC822.SIZE))) - (nnheader-insert-nov - ;; At this stage, we only have bytes, so let's use unibyte buffers - ;; to make it more clear. - (mm-with-unibyte-buffer - (buffer-disable-undo) - ;; headers can be nil if article is write-only - (when headers (insert headers)) - (let ((head (nnheader-parse-naked-head uid))) - (mail-header-set-number head uid) - (mail-header-set-chars head chars) - (mail-header-set-lines head lines) - (mail-header-set-xref - head (format "%s %s:%d" (system-name) mbx uid)) - head)))))) - -(defun nnimap-retrieve-which-headers (articles fetch-old) - "Get a range of articles to fetch based on ARTICLES and FETCH-OLD." - (with-current-buffer nnimap-server-buffer - (if (numberp (car-safe articles)) - (imap-search - (concat "UID " - (imap-range-to-message-set - (gnus-compress-sequence - (append (gnus-uncompress-sequence - (and fetch-old - (cons (if (numberp fetch-old) - (max 1 (- (car articles) fetch-old)) - 1) - (1- (car articles))))) - articles))))) - (mapcar (lambda (msgid) - (imap-search - (format "HEADER Message-Id \"%s\"" msgid))) - articles)))) +(defvar nnimap-split-methods nil) -(defun nnimap-group-overview-filename (group server) - "Make file name for GROUP on SERVER." - (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) - (uidvalidity (gnus-group-get-parameter - (nnimap-group-prefixed-name group server) - 'uidvalidity)) - (name (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group nnimap-nov-file-name-suffix) t)) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." uidvalidity - nnimap-nov-file-name-suffix) t)) - (oldfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name name dir))) - (expand-file-name name dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string name ?. ?/) - nnmail-pathname-coding-system) - dir))) - (newfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name nameuid dir))) - (expand-file-name nameuid dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string nameuid ?. ?/) - nnmail-pathname-coding-system) - dir)))) - (when (and (file-exists-p oldfile) (not (file-exists-p newfile))) - (message "nnimap: Upgrading novcache filename...") - (sit-for 1) - (gnus-make-directory (file-name-directory newfile)) - (unless (ignore-errors (rename-file oldfile newfile) t) - (if (ignore-errors (copy-file oldfile newfile) t) - (delete-file oldfile) - (error "Can't rename `%s' to `%s'" oldfile newfile)))) - newfile)) - -(defun nnimap-retrieve-headers-from-file (group server) - (with-current-buffer nntp-server-buffer - (let ((nov (nnimap-group-overview-filename group server))) - (when (file-exists-p nov) - (mm-insert-file-contents nov) - (set-buffer-modified-p nil) - (let ((min (ignore-errors (goto-char (point-min)) - (read (current-buffer)))) - (max (ignore-errors (goto-char (point-max)) - (forward-line -1) - (read (current-buffer))))) - (if (and (numberp min) (numberp max)) - (cons min max) - ;; junk, remove it, it's saved later - (erase-buffer) - nil)))))) - -(defun nnimap-retrieve-headers-from-server (articles group server) - (with-current-buffer nnimap-server-buffer - (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) - (nnimap-length (gnus-range-length articles)) - (nnimap-counter 0)) - (imap-fetch (imap-range-to-message-set articles) - (concat "(UID RFC822.SIZE BODY " - (let ((headers - (append '(Subject From Date Message-Id - References In-Reply-To Xref) - (copy-sequence - nnmail-extra-headers)))) - (if (imap-capability 'IMAP4rev1) - (format "BODY.PEEK[HEADER.FIELDS %s])" headers) - (format "RFC822.HEADER.LINES %s)" headers))))) - (with-current-buffer nntp-server-buffer - (sort-numeric-fields 1 (point-min) (point-max))) - (and (numberp nnmail-large-newsgroup) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers...done"))))) - -(defun nnimap-dont-use-nov-p (group server) - (or gnus-nov-is-evil nnimap-nov-is-evil - (unless (and (gnus-make-directory - (file-name-directory - (nnimap-group-overview-filename group server))) - (file-writable-p - (nnimap-group-overview-filename group server))) - (message "nnimap: Nov cache not writable, %s" - (nnimap-group-overview-filename group server))))) +(defun nnimap-buffer () + (nnimap-find-process-buffer nntp-server-buffer)) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) - (when (nnimap-possibly-change-group group server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (if (nnimap-dont-use-nov-p group server) - (nnimap-retrieve-headers-from-server - (gnus-compress-sequence articles) group server) - (let (uids cached low high) - (when (setq uids (nnimap-retrieve-which-headers articles fetch-old) - low (car uids) - high (car (last uids))) - (if (setq cached (nnimap-retrieve-headers-from-file group server)) - (progn - ;; fetch articles with uids before cache block - (when (< low (car cached)) - (goto-char (point-min)) - (nnimap-retrieve-headers-from-server - (cons low (1- (car cached))) group server)) - ;; fetch articles with uids after cache block - (when (> high (cdr cached)) - (goto-char (point-max)) - (nnimap-retrieve-headers-from-server - (cons (1+ (cdr cached)) high) group server)) - (when nnimap-prune-cache - ;; remove nov's for articles which has expired on server - (goto-char (point-min)) - (dolist (uid (gnus-set-difference articles uids)) - (when (re-search-forward (format "^%d\t" uid) nil t) - (gnus-delete-line))))) - ;; nothing cached, fetch whole range from server - (nnimap-retrieve-headers-from-server - (cons low high) group server)) - (when (buffer-modified-p) - (nnmail-write-region - (point-min) (point-max) - (nnimap-group-overview-filename group server) nil 'nomesg)) - (nnheader-nov-delete-outside-range low high)))) - 'nov))) - -(declare-function netrc-parse "netrc" (file)) -(declare-function netrc-machine-user-or-password "netrc" - (mode authinfo-file-or-list machines ports defaults)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (nnimap-send-command "SELECT %S" (utf7-encode group t)) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges (gnus-compress-sequence articles)) + (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" + (format + (if (member "IMAP4REV1" + (nnimap-capabilities nnimap-object)) + "BODY.PEEK[HEADER.FIELDS %s]" + "RFC822.HEADER.LINES %s") + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + nnmail-extra-headers)))) + t) + (nnimap-transform-headers)) + (insert-buffer-substring + (nnimap-find-process-buffer (current-buffer)))) + t)) -(defun nnimap-open-connection (server) - ;; Note: `nnimap-open-server' that calls this function binds - ;; `imap-logout-timeout' to `nnimap-logout-timeout'. - (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream - nnimap-authenticator nnimap-server-buffer)) - (nnheader-report 'nnimap "Can't open connection to server %s" server) - (require 'netrc) - (unless (or (imap-capability 'IMAP4 nnimap-server-buffer) - (imap-capability 'IMAP4rev1 nnimap-server-buffer)) - (imap-close nnimap-server-buffer) - (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) - (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'." - nnimap-authinfo-file) - (netrc-parse nnimap-authinfo-file))) - (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) - (auth-info - (auth-source-user-or-password '("login" "password") server port)) - (auth-user (nth 0 auth-info)) - (auth-passwd (nth 1 auth-info)) - (user (or - auth-user ; this is preferred to netrc-* - (netrc-machine-user-or-password - "login" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993")))) - (passwd (or - auth-passwd ; this is preferred to netrc-* - (netrc-machine-user-or-password - "password" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993"))))) - (if (imap-authenticate user passwd nnimap-server-buffer) - (prog2 - (setq nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist)) - (push (list server nnimap-server-buffer) - nnimap-server-buffer-alist) - (imap-id nnimap-id nnimap-server-buffer) - (nnimap-possibly-change-server server)) - (imap-close nnimap-server-buffer) - (kill-buffer nnimap-server-buffer) - (nnheader-report 'nnimap "Could not authenticate to %s" server))))) +(defun nnimap-transform-headers () + (goto-char (point-min)) + (let (article bytes lines size) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1) + bytes (nnimap-get-length) + lines nil) + (beginning-of-line) + (setq size + (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" + (line-end-position) + t) + (match-string 1))) + (beginning-of-line) + (when (search-forward "BODYSTRUCTURE" (line-end-position) t) + (let ((structure (ignore-errors (read (current-buffer))))) + (while (and (consp structure) + (not (stringp (car structure)))) + (setq structure (car structure))) + (setq lines (nth 7 structure)))) + (delete-region (line-beginning-position) (line-end-position)) + (insert (format "211 %s Article retrieved." article)) + (forward-line 1) + (when size + (insert (format "Chars: %s\n" size))) + (when lines + (insert (format "Lines: %s\n" lines))) + (re-search-forward "^\r$") + (delete-region (line-beginning-position) (line-end-position)) + (insert ".") + (forward-line 1))))) + +(defun nnimap-get-length () + (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) + (string-to-number (match-string 1)))) + +(defun nnimap-article-ranges (ranges) + (let (result) + (cond + ((numberp ranges) + (number-to-string ranges)) + ((numberp (cdr ranges)) + (format "%d:%d" (car ranges) (cdr ranges))) + (t + (dolist (elem ranges) + (push + (if (consp elem) + (format "%d:%d" (car elem) (cdr elem)) + (number-to-string elem)) + result)) + (mapconcat #'identity (nreverse result) ","))))) (deffoo nnimap-open-server (server &optional defs) - (nnheader-init-server-buffer) (if (nnimap-server-opened server) t - (unless (assq 'nnimap-server-buffer defs) - (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs)) - ;; translate `nnimap-server-address' to `nnimap-address' in defs - ;; for people that configured nnimap with a very old version (unless (assq 'nnimap-address defs) - (if (assq 'nnimap-server-address defs) - (push (list 'nnimap-address - (cadr (assq 'nnimap-server-address defs))) defs) - (push (list 'nnimap-address server) defs))) + (setq defs (append defs (list (list 'nnimap-address server))))) (nnoo-change-server 'nnimap server defs) - (or nnimap-server-buffer - (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) - (with-current-buffer (get-buffer-create nnimap-server-buffer) - (nnoo-change-server 'nnimap server defs)) - (let ((imap-logout-timeout nnimap-logout-timeout)) - (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer) - (if (with-current-buffer nnimap-server-buffer - (memq imap-state '(auth selected examine))) - t - (imap-close nnimap-server-buffer) - (nnimap-open-connection server))) - (nnimap-open-connection server))))) + (or (nnimap-find-connection nntp-server-buffer) + (nnimap-open-connection nntp-server-buffer)))) + +(defun nnimap-make-process-buffer (buffer) + (with-current-buffer + (generate-new-buffer (format "*nnimap %s %s %s*" + nnimap-address nnimap-server-port + (gnus-buffer-exists-p buffer))) + (mm-disable-multibyte) + (buffer-disable-undo) + (gnus-add-buffer) + (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'nnimap-object) (make-nnimap)) + (push (list buffer (current-buffer)) nnimap-connection-alist) + (current-buffer))) + +(defun nnimap-open-shell-stream (name buffer host port) + (let ((process-connection-type nil)) + (start-process name buffer shell-file-name + shell-command-switch + (format-spec + nnimap-shell-program + (format-spec-make + ?s host + ?p port))))) + +(defun nnimap-credentials (address ports) + (let (port credentials) + ;; Request the credentials from all ports, but only query on the + ;; last port if all the previous ones have failed. + (while (and (null credentials) + (setq port (pop ports))) + (setq credentials + (auth-source-user-or-password + '("login" "password") address port nil (null ports)))) + credentials)) + +(defun nnimap-open-connection (buffer) + (with-current-buffer (nnimap-make-process-buffer buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (ports + (cond + ((eq nnimap-stream 'network) + (open-network-stream + "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port + (if (netrc-find-service-number "imap") + "imap" + "143"))) + '("143" "imap")) + ((eq nnimap-stream 'shell) + (nnimap-open-shell-stream + "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port "imap")) + '("imap")) + ((eq nnimap-stream 'ssl) + (open-tls-stream + "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port + (if (netrc-find-service-number "imaps") + "imaps" + "993"))) + '("143" "993" "imap" "imaps")))) + connection-result login-result credentials) + (setf (nnimap-process nnimap-object) + (get-buffer-process (current-buffer))) + (when (and (nnimap-process nnimap-object) + (memq (process-status (nnimap-process nnimap-object)) + '(open run))) + (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) + (when (setq connection-result (nnimap-wait-for-connection)) + (unless (equal connection-result "PREAUTH") + (if (not (setq credentials + (if (eq nnimap-authenticator 'anonymous) + (list "anonymous" + (message-make-address)) + (nnimap-credentials + nnimap-address + (if nnimap-server-port + (cons (format "%s" nnimap-server-port) ports) + ports))))) + (setq nnimap-object nil) + (setq login-result (nnimap-command "LOGIN %S %S" + (car credentials) + (cadr credentials))) + (unless (car login-result) + (delete-process (nnimap-process nnimap-object)) + (setq nnimap-object nil)))) + (when nnimap-object + (setf (nnimap-capabilities nnimap-object) + (mapcar + #'upcase + (or (nnimap-find-parameter "CAPABILITY" (cdr login-result)) + (nnimap-find-parameter + "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))) + (when (member "QRESYNC" (nnimap-capabilities nnimap-object)) + (nnimap-command "ENABLE QRESYNC")) + t)))))) + +(defun nnimap-find-parameter (parameter elems) + (let (result) + (dolist (elem elems) + (cond + ((equal (car elem) parameter) + (setq result (cdr elem))) + ((and (equal (car elem) "OK") + (consp (cadr elem)) + (equal (caadr elem) parameter)) + (setq result (cdr (cadr elem)))))) + result)) + +(deffoo nnimap-close-server (&optional server) + t) + +(deffoo nnimap-request-close () + t) (deffoo nnimap-server-opened (&optional server) - "Whether SERVER is opened. -If SERVER is the current virtual server, and the connection to the -physical server is alive, this function return a non-nil value. If -SERVER is nil, it is treated as the current server." - ;; clean up autologouts?? - (and (or server nnimap-current-server) - (nnoo-server-opened 'nnimap (or server nnimap-current-server)) - (imap-opened (nnimap-get-server-buffer server)))) - -(deffoo nnimap-close-server (&optional server) - "Close connection to server and free all resources connected to it. -Return nil if the server couldn't be closed for some reason." - (let ((server (or server nnimap-current-server)) - (imap-logout-timeout nnimap-logout-timeout)) - (when (or (nnimap-server-opened server) - (imap-opened (nnimap-get-server-buffer server))) - (imap-close (nnimap-get-server-buffer server)) - (kill-buffer (nnimap-get-server-buffer server)) - (setq nnimap-server-buffer nil - nnimap-current-server nil - nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist))) - (nnoo-close-server 'nnimap server))) - -(deffoo nnimap-request-close () - "Close connection to all servers and free all resources that the backend have reserved. -All buffers that have been created by that -backend should be killed. (Not the nntp-server-buffer, though.) This -function is generally only called when Gnus is shutting down." - (mapc (lambda (server) (nnimap-close-server (car server))) - nnimap-server-buffer-alist) - (setq nnimap-server-buffer-alist nil)) + (and (nnoo-current-server-p 'nnimap server) + nntp-server-buffer + (gnus-buffer-live-p nntp-server-buffer) + (nnimap-find-connection nntp-server-buffer))) (deffoo nnimap-status-message (&optional server) - "This function returns the last error message from server." - (when (nnimap-possibly-change-server server) - (nnoo-status-message 'nnimap server))) - -;; We used to use a string-as-multibyte here, but it is really incorrect. -;; This function is used when we're about to insert a unibyte string -;; into a potentially multibyte buffer. The string is either an article -;; header or body (or both?), undecoded. When Emacs is asked to convert -;; a unibyte string to multibyte, it may either use the equivalent of -;; nothing (e.g. non-Mule XEmacs), string-make-unibyte (i.e. decode using -;; locale), string-as-multibyte (decode using emacs-internal coding system) -;; or string-to-multibyte (keep the data undecoded as a sequence of bytes). -;; Only the last one preserves the data such that we can reliably later on -;; decode the text using the mime info. -(defalias 'nnimap-demule 'mm-string-to-multibyte) - -(defun nnimap-make-callback (article gnus-callback buffer) - "Return a callback function." - `(lambda () - (nnimap-callback ,article ,gnus-callback ,buffer))) - -(defun nnimap-callback (article gnus-callback buffer) - (when (eq article (imap-current-message)) - (remove-hook 'imap-fetch-data-hook - (nnimap-make-callback article gnus-callback buffer)) - (with-current-buffer buffer - (insert - (with-current-buffer nnimap-server-buffer - (nnimap-demule - (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get article 'BODYDETAIL))) - (imap-message-get article 'RFC822))))) - (nnheader-ms-strip-cr) - (funcall gnus-callback t)))) - -(defun nnimap-request-article-part (article part prop &optional - group server to-buffer detail) - (when (nnimap-possibly-change-group group server) - (let ((article (if (stringp article) - (car-safe (imap-search - (format "HEADER Message-Id \"%s\"" article) - nnimap-server-buffer)) - article))) - (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name - gnus-newsgroup-name))) - (if (not nnheader-callback-function) - (with-current-buffer (or to-buffer nntp-server-buffer) - (erase-buffer) - (let ((data (imap-fetch article part prop nil - nnimap-server-buffer))) - ;; data can be nil if article is write-only - (when data - (insert (nnimap-demule (if detail - (nth 2 (car data)) - data))))) - (nnheader-ms-strip-cr) - (gnus-message - 10 "nnimap: Fetching (part of) article %d from %s...done" - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name gnus-newsgroup-name))) - (if (bobp) - (nnheader-report 'nnimap "No such article %d in %s: %s" - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name - gnus-newsgroup-name)) - (imap-error-text nnimap-server-buffer)) - (cons group article))) - (add-hook 'imap-fetch-data-hook - (nnimap-make-callback article - nnheader-callback-function - nntp-server-buffer)) - (imap-fetch-asynch article part nil nnimap-server-buffer) - (cons group article)))))) - -(deffoo nnimap-asynchronous-p () - t) + nnimap-status-string) (deffoo nnimap-request-article (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.PEEK" 'RFC822 group server to-buffer))) - -(deffoo nnimap-request-head (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))) - -(deffoo nnimap-request-body (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))) - -(deffoo nnimap-request-group (group &optional server fast) - (nnimap-request-update-info-internal - group - (gnus-get-info (nnimap-group-prefixed-name group server)) - server) - (when (nnimap-possibly-change-group group server) - (nnimap-before-find-minmax-bugworkaround) - (let (info) - (cond (fast group) - ((null (setq info (nnimap-find-minmax-uid group t))) - (nnheader-report 'nnimap "Could not get active info for %s" - group)) - (t - (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0) - (max 1 (or (nth 1 info) 1)) - (or (nth 2 info) 0) group) - (nnheader-report 'nnimap "Group %s selected" group) - t))))) - -(defun nnimap-update-unseen (group &optional server) - "Update the unseen count in `nnimap-mailbox-info'." - (gnus-sethash - (gnus-group-prefixed-name group server) - (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server) - nnimap-mailbox-info))) - (list (nth 0 old) (nth 1 old) - (imap-mailbox-status (nnimap-decode-group-name group) - 'unseen nnimap-server-buffer))) - nnimap-mailbox-info)) - -(defun nnimap-close-group (group &optional server) - (with-current-buffer nnimap-server-buffer - (when (and (imap-opened) - (nnimap-possibly-change-group group server)) - (nnimap-update-unseen group server) - (case nnimap-expunge-on-close - (always (progn - (imap-mailbox-expunge nnimap-close-asynchronous) - (unless nnimap-dont-close - (imap-mailbox-close nnimap-close-asynchronous)))) - (ask (if (and (imap-search "DELETED") - (gnus-y-or-n-p (format "Expunge articles in group `%s'? " - (imap-current-mailbox)))) - (progn - (imap-mailbox-expunge nnimap-close-asynchronous) - (unless nnimap-dont-close - (imap-mailbox-close nnimap-close-asynchronous))) - (imap-mailbox-unselect))) - (t (imap-mailbox-unselect))) - (not imap-current-mailbox)))) + (with-current-buffer nntp-server-buffer + (let ((result (nnimap-possibly-change-group group server)) + parts) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (when (and result + article) + (erase-buffer) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (when nnimap-fetch-partial-articles + (if (eq nnimap-fetch-partial-articles t) + (setq parts '(1)) + (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) + (goto-char (point-min)) + (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) + (let ((structure (ignore-errors (read (current-buffer))))) + (setq parts (nnimap-find-wanted-parts structure)))))) + (setq result + (nnimap-command + (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object)) + "UID FETCH %d BODY.PEEK[]" + "UID FETCH %d RFC822.PEEK") + article)) + ;; Check that we really got an article. + (goto-char (point-min)) + (unless (looking-at "\\* [0-9]+ FETCH") + (setq result nil))) + (let ((buffer (nnimap-find-process-buffer (current-buffer)))) + (when (car result) + (with-current-buffer (or to-buffer nntp-server-buffer) + (insert-buffer-substring buffer) + (goto-char (point-min)) + (let ((bytes (nnimap-get-length))) + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + (delete-region (point) (point-max)) + (nnheader-ms-strip-cr)) + (cons group article)))))))) -(defun nnimap-pattern-to-list-arguments (pattern) - (mapcar (lambda (p) - (cons (car-safe p) (or (cdr-safe p) p))) - (if (and (listp pattern) - (listp (cdr pattern))) - pattern - (list pattern)))) - -(deffoo nnimap-request-list (&optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (erase-buffer)) - (gnus-message 5 "nnimap: Generating active list%s..." - (if (> (length server) 0) (concat " for " server) "")) - (nnimap-before-find-minmax-bugworkaround) - (with-current-buffer nnimap-server-buffer - (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) - (dolist (mbx (funcall nnimap-request-list-method - (cdr pattern) (car pattern))) - (unless (member "\\noselect" - (mapcar #'downcase - (imap-mailbox-get 'list-flags mbx))) - (let* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - encoded-mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) - (gnus-message 5 "nnimap: Generating active list%s...done" - (if (> (length server) 0) (concat " for " server) "")) - t)) +(defun nnimap-find-wanted-parts (structure) + (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) -(deffoo nnimap-request-post (&optional server) - (let ((success t)) - (dolist (mbx (message-unquote-tokens - (message-tokenize-header - (message-fetch-field "Newsgroups") ", ")) success) - (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) - (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-command-method) - (gnus-activate-group to-newsgroup nil nil - gnus-command-method)) - (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) - (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method)) - (setq success nil)))))) - -;; Optional backend functions +(defun nnimap-find-wanted-parts-1 (structure prefix) + (let ((num 1) + parts) + (while (consp (car structure)) + (let ((sub (pop structure))) + (if (consp (car sub)) + (push (nnimap-find-wanted-parts-1 + sub (if (string= prefix "") + (number-to-string num) + (format "%s.%s" prefix num))) + parts) + (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))) + (when (string-match nnimap-fetch-partial-articles type) + (push (if (string= prefix "") + (number-to-string num) + (format "%s.%s" prefix num)) + parts))) + (incf num)))) + (nreverse parts))) -(defun nnimap-string-lessp-numerical (s1 s2) - "Return t if first arg string is less than second in numerical order." - (cond ((string= s1 s2) - nil) - ((> (length s1) (length s2)) - nil) - ((< (length s1) (length s2)) - t) - ((< (string-to-number (substring s1 0 1)) - (string-to-number (substring s2 0 1))) - t) - ((> (string-to-number (substring s1 0 1)) - (string-to-number (substring s2 0 1))) - nil) - (t - (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1))))) - -(deffoo nnimap-retrieve-groups (groups &optional server) - (when (nnimap-possibly-change-server server) - (gnus-message 5 "nnimap: Checking mailboxes...") +(deffoo nnimap-request-group (group &optional server dont-check info) + (let ((result (nnimap-possibly-change-group group server)) + articles active marks high low) (with-current-buffer nntp-server-buffer + (when result + (if (and dont-check + (setq active (nth 2 (assoc group nnimap-current-infos)))) + (insert (format "211 %d %d %d %S\n" + (- (cdr active) (car active)) + (car active) + (cdr active) + group)) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (let ((group-sequence + (nnimap-send-command "SELECT %S" (utf7-encode group t))) + (flag-sequence + (nnimap-send-command "UID FETCH 1:* FLAGS"))) + (nnimap-wait-for-response flag-sequence) + (setq marks + (nnimap-flags-to-marks + (nnimap-parse-flags + (list (list group-sequence flag-sequence 1 group))))) + (when info + (nnimap-update-infos marks (list info))) + (goto-char (point-max)) + (cond + (marks + (setq high (nth 3 (car marks)) + low (nth 4 (car marks)))) + ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t) + (setq high (1- (string-to-number (match-string 1))) + low 1))))) + (erase-buffer) + (insert + (format + "211 %d %d %d %S\n" (1+ (- high low)) low high group))) + t)))) + +(deffoo nnimap-request-create-group (group &optional server args) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-delete-group (group &optional force server) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-expunge-group (group &optional server) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "EXPUNGE"))))) + +(defun nnimap-get-flags (spec) + (let ((articles nil) + elems) + (with-current-buffer (nnimap-buffer) (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (let (asyncgroups slowgroups decoded-group) - (if (null nnimap-retrieve-groups-asynchronous) - (setq slowgroups groups) - (dolist (group groups) - (setq decoded-group (nnimap-decode-group-name group)) - (gnus-message 9 "nnimap: Quickly checking mailbox %s" - decoded-group) - (add-to-list (if (gnus-group-get-parameter - (nnimap-group-prefixed-name group) - 'imap-status) - 'asyncgroups - 'slowgroups) - (list group (imap-mailbox-status-asynch - decoded-group - '(uidvalidity uidnext unseen) - nnimap-server-buffer)))) - (dolist (asyncgroup asyncgroups) - (let* ((group (nth 0 asyncgroup)) - (tag (nth 1 asyncgroup)) - (gnusgroup (nnimap-group-prefixed-name group)) - (saved-uidvalidity (gnus-group-get-parameter gnusgroup - 'uidvalidity)) - (saved-imap-status (gnus-group-get-parameter gnusgroup - 'imap-status)) - (saved-info (and saved-imap-status - (split-string saved-imap-status " ")))) - (setq decoded-group (nnimap-decode-group-name group)) - (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) - (if (or (not (equal - saved-uidvalidity - (imap-mailbox-get 'uidvalidity decoded-group - nnimap-server-buffer))) - (not (equal - (nth 0 saved-info) - (imap-mailbox-get 'uidnext decoded-group - nnimap-server-buffer)))) - (push (list group) slowgroups) - (gnus-sethash - (gnus-group-prefixed-name group server) - (list (imap-mailbox-get 'uidvalidity - decoded-group nnimap-server-buffer) - (imap-mailbox-get 'uidnext - decoded-group nnimap-server-buffer) - (imap-mailbox-get 'unseen - decoded-group nnimap-server-buffer)) - nnimap-mailbox-info) - (insert (format "\"%s\" %s %s y\n" group - (nth 2 saved-info) - (nth 1 saved-info)))))))) - (dolist (group slowgroups) - (if nnimap-retrieve-groups-asynchronous - (setq group (car group))) - (setq decoded-group (nnimap-decode-group-name group)) - (gnus-message 7 "nnimap: Mailbox %s modified" decoded-group) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags decoded-group - nnimap-server-buffer)) - (let* ((gnusgroup (nnimap-group-prefixed-name group)) - (status (imap-mailbox-status - decoded-group '(uidvalidity uidnext unseen) - nnimap-server-buffer)) - (info (nnimap-find-minmax-uid group 'examine)) - (min-uid (max 1 (or (nth 1 info) 1))) - (max-uid (or (nth 2 info) 0))) - (when (> (or (imap-mailbox-get 'recent decoded-group - nnimap-server-buffer) 0) - 0) - (push (list (cons decoded-group 0)) nnmail-split-history)) - (insert (format "\"%s\" %d %d y\n" group max-uid min-uid)) - (gnus-sethash - (gnus-group-prefixed-name group server) - status - nnimap-mailbox-info) - (if (not (equal (nth 0 status) - (gnus-group-get-parameter gnusgroup - 'uidvalidity))) - (nnimap-verify-uidvalidity group nnimap-current-server)) - ;; The imap-status parameter is a string on the form - ;; "<uidnext> <min-uid> <max-uid>". - (gnus-group-add-parameter - gnusgroup - (cons 'imap-status - (format "%s %s %s" (nth 1 status) min-uid max-uid)))))))) - (gnus-message 5 "nnimap: Checking mailboxes...done") - 'active)) + (nnimap-wait-for-response (nnimap-send-command + "UID FETCH %s FLAGS" spec)) + (goto-char (point-min)) + (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t) + (setq elems (nnimap-parse-line (match-string 1))) + (push (cons (string-to-number (cadr (member "UID" elems))) + (cadr (member "FLAGS" elems))) + articles))) + (nreverse articles))) + +(deffoo nnimap-close-group (group &optional server) + t) + +(deffoo nnimap-request-move-article (article group server accept-form + &optional last internal-move-group) + (with-temp-buffer + (when (nnimap-request-article article group server (current-buffer)) + ;; If the move is internal (on the same server), just do it the easy + ;; way. + (let ((message-id (message-field-value "message-id"))) + (if internal-move-group + (let ((result + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID COPY %d %S" + article + (utf7-encode internal-move-group t))))) + (when (car result) + (nnimap-delete-article article) + (cons internal-move-group + (nnimap-find-article-by-message-id + internal-move-group message-id)))) + ;; Move the article to a different method. + (let ((result (eval accept-form))) + (when result + (nnimap-delete-article article) + result))))))) + +(deffoo nnimap-request-expire-articles (articles group &optional server force) + (cond + ((null articles) + nil) + ((not (nnimap-possibly-change-group group server)) + articles) + ((and force + (eq nnmail-expiry-target 'delete)) + (unless (nnimap-delete-article articles) + (message "Article marked for deletion, but not expunged.")) + nil) + (t + (let ((deletable-articles + (if force + articles + (gnus-sorted-intersection + articles + (nnimap-find-expired-articles group))))) + (if (null deletable-articles) + articles + (if (eq nnmail-expiry-target 'delete) + (nnimap-delete-article deletable-articles) + (setq deletable-articles + (nnimap-process-expiry-targets + deletable-articles group server))) + ;; Return the articles we didn't delete. + (gnus-sorted-complement articles deletable-articles)))))) -(deffoo nnimap-request-update-info-internal (group info &optional server) - (when (nnimap-possibly-change-group group server) - (when info ;; xxx what does this mean? should we create a info? - (with-current-buffer nnimap-server-buffer - (gnus-message 5 "nnimap: Updating info for %s..." - (nnimap-decode-group-name (gnus-info-group info))) +(defun nnimap-process-expiry-targets (articles group server) + (let ((deleted-articles nil)) + (dolist (article articles) + (let ((target nnmail-expiry-target)) + (with-temp-buffer + (when (nnimap-request-article article group server (current-buffer)) + (message "Expiring article %s:%d" group article) + (when (functionp target) + (setq target (funcall target group))) + (when (and target + (not (eq target 'delete))) + (if (or (gnus-request-group target t) + (gnus-request-create-group target)) + (nnmail-expiry-target-group target group) + (setq target nil))) + (when target + (push article deleted-articles)))))) + ;; Change back to the current group again. + (nnimap-possibly-change-group group server) + (setq deleted-articles (nreverse deleted-articles)) + (nnimap-delete-article deleted-articles) + deleted-articles)) - (when (nnimap-mark-permanent-p 'read) - (let (seen unseen) - ;; read info could contain articles marked unread by other - ;; imap clients! we correct this - (setq unseen (gnus-compress-sequence - (imap-search "UNSEEN UNDELETED")) - seen (gnus-range-difference (gnus-info-read info) unseen) - seen (gnus-range-add seen - (gnus-compress-sequence - (imap-search "SEEN"))) - seen (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen)) - (gnus-info-set-read info seen))) +(defun nnimap-find-expired-articles (group) + (let ((cutoff (nnmail-expired-article-p group nil nil))) + (with-current-buffer (nnimap-buffer) + (let ((result + (nnimap-command + "UID SEARCH SENTBEFORE %s" + (format-time-string + (format "%%d-%s-%%Y" + (upcase + (car (rassoc (nth 4 (decode-time cutoff)) + parse-time-months)))) + cutoff)))) + (and (car result) + (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))))))) - (dolist (pred gnus-article-mark-lists) - (when (or (eq (cdr pred) 'recent) - (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags)))) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (gnus-compress-sequence - (imap-search (nnimap-mark-to-predicate (cdr pred)))) - (gnus-info-marks info)) - t))) + +(defun nnimap-find-article-by-message-id (group message-id) + (when (nnimap-possibly-change-group group nil) + (with-current-buffer (nnimap-buffer) + (let ((result + (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id)) + article) + (when (car result) + ;; Select the last instance of the message in the group. + (and (setq article + (car (last (assoc "SEARCH" (cdr result))))) + (string-to-number article))))))) - (when nnimap-importantize-dormant - ;; nnimap mark dormant article as ticked too (for other clients) - ;; so we remove that mark for gnus since we support dormant - (gnus-info-set-marks - info - (gnus-update-alist-soft - 'tick - (gnus-remove-from-range - (cdr-safe (assoc 'tick (gnus-info-marks info))) - (cdr-safe (assoc 'dormant (gnus-info-marks info)))) - (gnus-info-marks info)) - t)) +(defun nnimap-delete-article (articles) + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" + (nnimap-article-ranges articles)) + (cond + ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (nnimap-command "UID EXPUNGE %s" + (nnimap-article-ranges articles)) + t) + (nnimap-expunge + (nnimap-command "EXPUNGE") + t)))) - (gnus-message 5 "nnimap: Updating info for %s...done" - (nnimap-decode-group-name (gnus-info-group info))) - - info)))) +(deffoo nnimap-request-scan (&optional group server) + (when (and (nnimap-possibly-change-group nil server) + (equal group nnimap-inbox) + nnimap-inbox + nnimap-split-methods) + (nnimap-split-incoming-mail))) -(deffoo nnimap-request-type (group &optional article) - (if (and nnimap-news-groups (string-match nnimap-news-groups group)) - 'news - 'mail)) +(defun nnimap-marks-to-flags (marks) + (let (flags flag) + (dolist (mark marks) + (when (setq flag (cadr (assq mark nnimap-mark-alist))) + (push flag flags))) + flags)) (deffoo nnimap-request-set-mark (group actions &optional server) (when (nnimap-possibly-change-group group server) - (with-current-buffer nnimap-server-buffer - (let (action) - (gnus-message 7 "nnimap: Setting marks in %s..." - (nnimap-decode-group-name group)) - (while (setq action (pop actions)) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (cmdmarks (nth 2 action)) - marks) - ;; bookmark can't be stored (not list/range - (setq cmdmarks (delq 'bookmark cmdmarks)) - ;; killed can't be stored (not list/range - (setq cmdmarks (delq 'killed cmdmarks)) - ;; unsent are for nndraft groups only - (setq cmdmarks (delq 'unsent cmdmarks)) - ;; cache flags are pointless on the server - (setq cmdmarks (delq 'cache cmdmarks)) - ;; seen flags are local to each gnus - (setq cmdmarks (delq 'seen cmdmarks)) - ;; recent marks can't be set - (setq cmdmarks (delq 'recent cmdmarks)) - (when nnimap-importantize-dormant - ;; flag dormant articles as ticked - (if (memq 'dormant cmdmarks) - (setq cmdmarks (cons 'tick cmdmarks)))) - ;; remove stuff we are forbidden to store - (mapc (lambda (mark) - (if (imap-message-flag-permanent-p - (nnimap-mark-to-flag mark)) - (setq marks (cons mark marks)))) - cmdmarks) - (when (and range marks) - (cond ((eq what 'del) - (imap-message-flags-del - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'add) - (imap-message-flags-add - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'set) - (imap-message-flags-set - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))))))) - (gnus-message 7 "nnimap: Setting marks in %s...done" - (nnimap-decode-group-name group))))) - nil) + (let (sequence) + (with-current-buffer (nnimap-buffer) + ;; Just send all the STORE commands without waiting for + ;; response. If they're successful, they're successful. + (dolist (action actions) + (destructuring-bind (range action marks) action + (let ((flags (nnimap-marks-to-flags marks))) + (when flags + (setq sequence (nnimap-send-command + "UID STORE %s %sFLAGS.SILENT (%s)" + (nnimap-article-ranges range) + (if (eq action 'del) + "-" + "+") + (mapconcat #'identity flags " "))))))) + ;; Wait for the last command to complete to avoid later + ;; syncronisation problems with the stream. + (when sequence + (nnimap-wait-for-response sequence)))))) -(defun nnimap-split-fancy () - "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'." - (let ((nnmail-split-fancy nnimap-split-fancy)) - (nnmail-split-fancy))) +(deffoo nnimap-request-accept-article (group &optional server last) + (when (nnimap-possibly-change-group nil server) + (nnmail-check-syntax) + (let ((message (buffer-string)) + (message-id (message-field-value "message-id")) + sequence) + (with-current-buffer (nnimap-buffer) + (setq sequence (nnimap-send-command + "APPEND %S {%d}" (utf7-encode group t) + (length message))) + (process-send-string (get-buffer-process (current-buffer)) message) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n")) + (let ((result (nnimap-get-response sequence))) + (when result + (cons group + (nnimap-find-article-by-message-id group message-id)))))))) -(defun nnimap-split-to-groups (rules) - ;; tries to match all rules in nnimap-split-rule against content of - ;; nntp-server-buffer, returns a list of groups that matched. - ;; Note: This function takes and returns decoded group names. +(defun nnimap-add-cr () + (goto-char (point-min)) + (while (re-search-forward "\r?\n" nil t) + (replace-match "\r\n" t t))) + +(defun nnimap-get-groups () + (let ((result (nnimap-command "LIST \"\" \"*\"")) + groups) + (when (car result) + (dolist (line (cdr result)) + (when (and (equal (car line) "LIST") + (not (and (caadr line) + (string-match "noselect" (caadr line))))) + (push (car (last line)) groups))) + (nreverse groups)))) + +(deffoo nnimap-request-list (&optional server) + (nnimap-possibly-change-group nil server) (with-current-buffer nntp-server-buffer - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - (if (functionp rules) - (funcall rules) - (let (to-groups regrepp) - (catch 'split-done - (dolist (rule rules to-groups) - (let ((group (car rule)) - (regexp (cadr rule))) - (goto-char (point-min)) - (when (and (if (stringp regexp) - (progn - (if (not (stringp group)) - (setq group (eval group)) - (setq regrepp - (string-match "\\\\[0-9&]" group))) - (re-search-forward regexp nil t)) - (funcall regexp group)) - ;; Don't enter the article into the same group twice. - (not (assoc group to-groups))) - (push (if regrepp - (nnmail-expand-newtext group) + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (with-current-buffer (nnimap-buffer) + (dolist (group groups) + (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) group) - to-groups) - (or nnimap-split-crosspost - (throw 'split-done to-groups)))))))))) - -(defun nnimap-assoc-match (key alist) - (let (element) - (while (and alist (not element)) - (if (string-match (car (car alist)) key) - (setq element (car alist))) - (setq alist (cdr alist))) - element)) - -(defun nnimap-split-find-rule (server inbox) - (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule)) - (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) - ;; extended format - (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match - server nnimap-split-rule)))) - nnimap-split-rule)) - -(defun nnimap-split-find-inbox (server) - (if (listp nnimap-split-inbox) - nnimap-split-inbox - (list nnimap-split-inbox))) - -(defun nnimap-split-articles (&optional group server) - ;; Note: Assumes decoded group names in nnimap-split-inbox, - ;; nnimap-split-rule, nnimap-split-fancy, and nnmail-split-history. - (when (nnimap-possibly-change-server server) - (with-current-buffer nnimap-server-buffer - (let (rule inbox removeorig - (inboxes (nnimap-split-find-inbox server))) - ;; iterate over inboxes - (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group - (nnimap-encode-group-name inbox))) ;; SELECT - ;; find split rule for this server / inbox - (when (setq rule (nnimap-split-find-rule server inbox)) - ;; iterate over articles - (dolist (article (imap-search nnimap-split-predicate)) - (when (if (if (eq nnimap-split-download-body 'default) - nnimap-split-download-body-default - nnimap-split-download-body) - (and (nnimap-request-article article) - (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) - (nnimap-request-head article)) - ;; copy article to right group(s) - (setq removeorig nil) - (dolist (to-group (nnimap-split-to-groups rule)) - (cond ((eq to-group 'junk) - (message "IMAP split removed %s:%s:%d" server inbox - article) - (setq removeorig t)) - ((imap-message-copy (number-to-string article) - to-group nil 'nocopyuid) - (message "IMAP split moved %s:%s:%d to %s" server - inbox article to-group) - (setq removeorig t) - (when nnmail-cache-accepted-message-ids - (with-current-buffer nntp-server-buffer - (let (msgid) - (and (setq msgid - (nnmail-fetch-field "message-id")) - (nnmail-cache-insert msgid - (nnimap-encode-group-name to-group) - (nnmail-fetch-field "subject")))))) - ;; Add the group-art list to the history list. - (push (list (cons to-group 0)) nnmail-split-history)) - (t - (message "IMAP split failed to move %s:%s:%d to %s" - server inbox article to-group)))) - (if (if (eq nnimap-split-download-body 'default) - nnimap-split-download-body-default - nnimap-split-download-body) - (widen)) - ;; remove article if it was successfully copied somewhere - (and removeorig - (imap-message-flags-add (format "%d" article) - "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox) ;; just in case - ;; todo: UID EXPUNGE (if available) to remove splitted articles - (imap-mailbox-expunge) - (imap-mailbox-close))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-close)) + sequences)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences)))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" (utf7-decode group t)))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" + (utf7-decode group t) highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" (utf7-decode group t) + (or highest exists))))))))) t)))) -(deffoo nnimap-request-scan (&optional group server) - (nnimap-split-articles group server)) - -(deffoo nnimap-request-newgroups (date &optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..." - (if (> (length server) 0) " on " "") server) - (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (dolist (pattern (nnimap-pattern-to-list-arguments - nnimap-list-pattern)) - (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern) nil - nnimap-server-buffer)) - (or (catch 'found - (dolist (mailbox (imap-mailbox-get 'list-flags mbx - nnimap-server-buffer)) - (if (string= (downcase mailbox) "\\noselect") - (throw 'found t))) - nil) - (let* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (insert (format "\"%s\" %d %d y\n" - encoded-mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))) - (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" - (if (> (length server) 0) " on " "") server)) - t)) - -(deffoo nnimap-request-create-group (group &optional server args) - (when (nnimap-possibly-change-server server) - (let ((decoded-group (nnimap-decode-group-name group))) - (or (imap-mailbox-status decoded-group 'uidvalidity nnimap-server-buffer) - (imap-mailbox-create decoded-group nnimap-server-buffer) - (nnheader-report 'nnimap "%S" - (imap-error-text nnimap-server-buffer)))))) +(deffoo nnimap-retrieve-group-data-early (server infos) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + ;; QRESYNC handling isn't implemented. + (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object))) + marks groups sequences) + ;; Go through the infos and gather the data needed to know + ;; what and how to request the data. + (dolist (info infos) + (setq marks (gnus-info-marks info)) + (push (list (gnus-group-real-name (gnus-info-group info)) + (cdr (assq 'active marks)) + (cdr (assq 'uid marks))) + groups)) + ;; Then request the data. + (erase-buffer) + (dolist (elem groups) + (if (and qresyncp + (nth 2 elem)) + (push + (list 'qresync + (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (car elem) + (car (nth 2 elem)) + (cdr (nth 2 elem))) + nil + (car elem)) + sequences) + (let ((start + (if (nth 1 elem) + ;; Fetch the last 100 flags. + (max 1 (- (cdr (nth 1 elem)) 100)) + 1))) + (push (list (nnimap-send-command "EXAMINE %S" (car elem)) + (nnimap-send-command "UID FETCH %d:* FLAGS" start) + start + (car elem)) + sequences)))) + sequences)))) -(defun nnimap-time-substract (time1 time2) - "Return TIME for TIME1 - TIME2." - (let* ((ms (- (car time1) (car time2))) - (ls (- (nth 1 time1) (nth 1 time2)))) - (if (< ls 0) - (list (- ms 1) (+ (expt 2 16) ls)) - (list ms ls)))) +(deffoo nnimap-finish-retrieve-group-infos (server infos sequences) + (when (and sequences + (nnimap-possibly-change-group nil server)) + (with-current-buffer (nnimap-buffer) + ;; Wait for the final data to trickle in. + (nnimap-wait-for-response (cadar sequences)) + ;; Now we should have all the data we need, no matter whether + ;; we're QRESYNCING, fetching all the flags from scratch, or + ;; just fetching the last 100 flags per group. + (nnimap-update-infos (nnimap-flags-to-marks + (nnimap-parse-flags + (nreverse sequences))) + infos) + ;; Finally, just return something resembling an active file in + ;; the nntp buffer, so that the agent can save the info, too. + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (info infos) + (let* ((group (gnus-info-group info)) + (active (gnus-active group))) + (when active + (insert (format "%S %d %d y\n" + (gnus-group-real-name group) + (cdr active) + (car active)))))))))) -(eval-when-compile (require 'parse-time)) -(defun nnimap-date-days-ago (daysago) - "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago." - (require 'parse-time) - (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago))) - (date (format-time-string - (format "%%d-%s-%%Y" - (capitalize (car (rassoc (nth 4 (decode-time time)) - parse-time-months)))) - time))) - (if (eq ?0 (string-to-char date)) - (substring date 1) - date))) - -(defun nnimap-request-expire-articles-progress () - (gnus-message 5 "nnimap: Marking article %d for deletion..." - imap-current-message)) - -(defun nnimap-expiry-target (arts group server) - (unless (eq nnmail-expiry-target 'delete) - (with-temp-buffer - (dolist (art arts) - (nnimap-request-article art group server (current-buffer)) - ;; hints for optimization in `nnimap-request-accept-article' - (let ((nnimap-current-move-article art) - (nnimap-current-move-group group) - (nnimap-current-move-server server)) - (nnmail-expiry-target-group nnmail-expiry-target group)))) - ;; It is not clear if `nnmail-expiry-target' somehow cause the - ;; current group to be changed or not, so we make sure here. - (nnimap-possibly-change-group group server))) +(defun nnimap-update-infos (flags infos) + (dolist (info infos) + (let ((group (gnus-group-real-name (gnus-info-group info)))) + (nnimap-update-info info (cdr (assoc group flags)))))) -;; Notice that we don't actually delete anything, we just mark them deleted. -(deffoo nnimap-request-expire-articles (articles group &optional server force) - (let ((artseq (gnus-compress-sequence articles))) - (when (and artseq (nnimap-possibly-change-group group server)) - (with-current-buffer nnimap-server-buffer - (let ((days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait))) - (cond ((or force (eq days 'immediate)) - (let ((oldarts (imap-search - (concat "UID " - (imap-range-to-message-set artseq))))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts)))))) - ((and nnimap-search-uids-not-since-is-evil (numberp days)) - (let* ((all-new-articles - (gnus-compress-sequence - (imap-search (format "SINCE %s" - (nnimap-date-days-ago days))))) - (oldartseq - (gnus-range-difference artseq all-new-articles)) - (oldarts (gnus-uncompress-range oldartseq))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set oldartseq) - "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts)))))) - ((numberp days) - (let ((oldarts (imap-search - (format nnimap-expunge-search-string - (imap-range-to-message-set artseq) - (nnimap-date-days-ago days)))) - (imap-fetch-data-hook - '(nnimap-request-expire-articles-progress))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts))))))))))) - ;; return articles not deleted - articles) +(defun nnimap-update-info (info marks) + (when marks + (destructuring-bind (existing flags high low uidnext start-article) marks + (let ((group (gnus-info-group info)) + (completep (and start-article + (= start-article 1)))) + ;; First set the active ranges based on high/low. + (if (or completep + (not (gnus-active group))) + (gnus-set-active group + (if high + (cons low high) + ;; No articles in this group. + (cons (1- uidnext) uidnext))) + (setcdr (gnus-active group) high)) + ;; Then update the list of read articles. + (let* ((unread + (gnus-compress-sequence + (gnus-set-difference + (gnus-set-difference + existing + (cdr (assoc "\\Seen" flags))) + (cdr (assoc "\\Flagged" flags))))) + (read (gnus-range-difference + (cons start-article high) unread))) + (when (> start-article 1) + (setq read + (gnus-range-nconcat + (if (> start-article 1) + (gnus-sorted-range-intersection + (cons 1 (1- start-article)) + (gnus-info-read info)) + (gnus-info-read info)) + read))) + (gnus-info-set-read info read) + ;; Update the marks. + (setq marks (gnus-info-marks info)) + ;; Note the active level for the next run-through. + (let ((active (assq 'active marks))) + (if active + (setcdr active (gnus-active group)) + (push (cons 'active (gnus-active group)) marks))) + (dolist (type (cdr nnimap-mark-alist)) + (let ((old-marks (assoc (car type) marks)) + (new-marks (gnus-compress-sequence + (cdr (assoc (cadr type) flags))))) + (setq marks (delq old-marks marks)) + (pop old-marks) + (when (and old-marks + (> start-article 1)) + (setq old-marks (gnus-range-difference + old-marks + (cons start-article high))) + (setq new-marks (gnus-range-nconcat old-marks new-marks))) + (when new-marks + (push (cons (car type) new-marks) marks))) + (gnus-info-set-marks info marks t) + (nnimap-store-info info (gnus-active group)))))))) + +(defun nnimap-store-info (info active) + (let* ((group (gnus-group-real-name (gnus-info-group info))) + (entry (assoc group nnimap-current-infos))) + (if entry + (setcdr entry (list info active)) + (push (list group info active) nnimap-current-infos)))) + +(defun nnimap-flags-to-marks (groups) + (let (data group totalp uidnext articles start-article mark) + (dolist (elem groups) + (setq group (car elem) + uidnext (cadr elem) + start-article (caddr elem) + articles (cdddr elem)) + (let ((high (caar articles)) + marks low existing) + (dolist (article articles) + (setq low (car article)) + (push (car article) existing) + (dolist (flag (cdr article)) + (setq mark (assoc flag marks)) + (if (not mark) + (push (list flag (car article)) marks) + (setcdr mark (cons (car article) (cdr mark))))) + (push (list group existing marks high low uidnext start-article) + data)))) + data)) -(deffoo nnimap-request-move-article (article group server accept-form - &optional last move-is-internal) - (when (nnimap-possibly-change-server server) - (save-excursion - (let ((buf (get-buffer-create " *nnimap move*")) - (nnimap-current-move-article article) - (nnimap-current-move-group group) - (nnimap-current-move-server nnimap-current-server) - result) - (gnus-message 10 "nnimap-request-move-article: this is an %s move" - (if move-is-internal - "internal" - "external")) - ;; request the article only when the move is NOT internal - (and (or move-is-internal - (nnimap-request-article article group server)) - (with-current-buffer buf - (buffer-disable-undo (current-buffer)) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer buf) - result) - (nnimap-possibly-change-group group server) - (imap-message-flags-add - (imap-range-to-message-set (list article)) - "\\Deleted" 'silent nnimap-server-buffer)) - result)))) +(defun nnimap-parse-flags (sequences) + (goto-char (point-min)) + (let (start end articles groups uidnext elems) + (dolist (elem sequences) + (destructuring-bind (group-sequence flag-sequence totalp group) elem + ;; The EXAMINE was successful. + (when (and (search-forward (format "\n%d OK " group-sequence) nil t) + (progn + (forward-line 1) + (setq start (point)) + (if (re-search-backward "UIDNEXT \\([0-9]+\\)" + (or end (point-min)) t) + (setq uidnext (string-to-number (match-string 1))) + (setq uidnext nil)) + (goto-char start)) + ;; The UID FETCH FLAGS was successful. + (search-forward (format "\n%d OK " flag-sequence) nil t)) + (setq end (point)) + (goto-char start) + (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t) + (setq elems (nnimap-parse-line (match-string 1))) + (push (cons (string-to-number (cadr (member "UID" elems))) + (cadr (member "FLAGS" elems))) + articles)) + (push (nconc (list group uidnext totalp) articles) groups) + (setq articles nil)))) + groups)) + +(defun nnimap-find-process-buffer (buffer) + (cadr (assoc buffer nnimap-connection-alist))) + +(deffoo nnimap-request-post (&optional server) + (setq nnimap-status-string "Read-only server") + nil) + +(defun nnimap-possibly-change-group (group server) + (let ((open-result t)) + (when (and server + (not (nnimap-server-opened server))) + (setq open-result (nnimap-open-server server))) + (cond + ((not open-result) + nil) + ((not group) + t) + (t + (with-current-buffer (nnimap-buffer) + (if (equal group (nnimap-group nnimap-object)) + t + (let ((result (nnimap-command "SELECT %S" (utf7-encode group t)))) + (when (car result) + (setf (nnimap-group nnimap-object) group + (nnimap-select-result nnimap-object) result) + result)))))))) + +(defun nnimap-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assoc buffer nnimap-connection-alist))) + (when entry + (if (and (buffer-name (cadr entry)) + (get-buffer-process (cadr entry)) + (memq (process-status (get-buffer-process (cadr entry))) + '(open run))) + (get-buffer-process (cadr entry)) + (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) + nil)))) + +(defvar nnimap-sequence 0) + +(defun nnimap-send-command (&rest args) + (process-send-string + (get-buffer-process (current-buffer)) + (nnimap-log-command + (format "%d %s%s\n" + (incf nnimap-sequence) + (apply #'format args) + (if (nnimap-newlinep nnimap-object) + "" + "\r")))) + nnimap-sequence) + +(defun nnimap-log-command (command) + (with-current-buffer (get-buffer-create "*imap log*") + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") " " command)) + command) -(deffoo nnimap-request-accept-article (group &optional server last) - (when (nnimap-possibly-change-server server) - (let (uid) - (if (setq uid - (if (string= nnimap-current-server nnimap-current-move-server) - ;; moving article within same server, speed it up... - (and (nnimap-possibly-change-group - nnimap-current-move-group) - (imap-message-copy (number-to-string - nnimap-current-move-article) - (nnimap-decode-group-name group) - 'dontcreate nil - nnimap-server-buffer)) - (with-current-buffer (current-buffer) - (goto-char (point-min)) - ;; remove any 'From blabla' lines, some IMAP servers - ;; reject the entire message otherwise. - (when (looking-at "^From[^:]") - (delete-region (point) (progn (forward-line) (point)))) - ;; turn into rfc822 format (\r\n eol's) - (while (search-forward "\n" nil t) - (replace-match "\r\n")) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") - group - (nnmail-fetch-field "subject")))) - (when (and last nnmail-cache-accepted-message-ids) - (nnmail-cache-close)) - ;; this 'or' is for Cyrus server bug - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (imap-message-append (nnimap-decode-group-name group) - (current-buffer) nil nil - nnimap-server-buffer))) - (cons group (nth 1 uid)) - (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer)))))) +(defun nnimap-command (&rest args) + (erase-buffer) + (let* ((sequence (apply #'nnimap-send-command args)) + (response (nnimap-get-response sequence))) + (if (equal (caar response) "OK") + (cons t response) + (nnheader-report 'nnimap "%s" + (mapconcat (lambda (a) + (format "%s" a)) + (car response) " ")) + nil))) + +(defun nnimap-get-response (sequence) + (nnimap-wait-for-response sequence) + (nnimap-parse-response)) + +(defun nnimap-wait-for-connection () + (let ((process (get-buffer-process (current-buffer)))) + (goto-char (point-min)) + (while (and (memq (process-status process) + '(open run)) + (not (re-search-forward "^\\* .*\n" nil t))) + (nnheader-accept-process-output process) + (goto-char (point-min))) + (forward-line -1) + (and (looking-at "\\* \\([A-Z0-9]+\\)") + (match-string 1)))) + +(defun nnimap-wait-for-response (sequence &optional messagep) + (let ((process (get-buffer-process (current-buffer)))) + (goto-char (point-max)) + (while (and (memq (process-status process) + '(open run)) + (not (re-search-backward (format "^%d .*\n" sequence) + (max (point-min) (- (point) 500)) + t))) + (when messagep + (message "Read %dKB" (/ (buffer-size) 1000))) + (nnheader-accept-process-output process) + (goto-char (point-max))))) + +(defun nnimap-parse-response () + (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) + result) + (dolist (line lines) + (push (cdr (nnimap-parse-line line)) result)) + ;; Return the OK/error code first, and then all the "continuation + ;; lines" afterwards. + (cons (pop result) + (nreverse result)))) -(deffoo nnimap-request-delete-group (group force &optional server) - (when (nnimap-possibly-change-server server) - (setq group (nnimap-decode-group-name group)) - (when (string= group (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (with-current-buffer nnimap-server-buffer - (if force - (or (null (imap-mailbox-status group 'uidvalidity)) - (imap-mailbox-delete group)) - ;; UNSUBSCRIBE? - t)))) +;; Parse an IMAP response line lightly. They look like +;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse +;; the lines into a list of strings and lists of string. +(defun nnimap-parse-line (line) + (let (char result) + (with-temp-buffer + (insert line) + (goto-char (point-min)) + (while (not (eobp)) + (if (eql (setq char (following-char)) ? ) + (forward-char 1) + (push + (cond + ((eql char ?\[) + (split-string (buffer-substring + (1+ (point)) (1- (search-forward "]"))))) + ((eql char ?\() + (split-string (buffer-substring + (1+ (point)) (1- (search-forward ")"))))) + ((eql char ?\") + (forward-char 1) + (buffer-substring (point) (1- (search-forward "\"")))) + (t + (buffer-substring (point) (if (search-forward " " nil t) + (1- (point)) + (goto-char (point-max)))))) + result))) + (nreverse result)))) -(deffoo nnimap-request-rename-group (group new-name &optional server) - (when (nnimap-possibly-change-server server) - (imap-mailbox-rename (nnimap-decode-group-name group) - (nnimap-decode-group-name new-name) - nnimap-server-buffer))) +(defun nnimap-last-response-string () + (save-excursion + (forward-line 1) + (let ((end (point))) + (forward-line -1) + (when (not (bobp)) + (forward-line -1) + (while (and (not (bobp)) + (eql (following-char) ?*)) + (forward-line -1)) + (unless (eql (following-char) ?*) + (forward-line 1))) + (buffer-substring (point) end)))) -(defun nnimap-expunge (mailbox server) - (when (nnimap-possibly-change-group mailbox server) - (imap-mailbox-expunge nil nnimap-server-buffer))) +(defun nnimap-get-responses (sequences) + (let (responses) + (dolist (sequence sequences) + (goto-char (point-min)) + (when (re-search-forward (format "^%d " sequence) nil t) + (push (list sequence (nnimap-parse-response)) + responses))) + responses)) + +(defvar nnimap-incoming-split-list nil) -(defun nnimap-acl-get (mailbox server) - (when (nnimap-possibly-change-server server) - (and (imap-capability 'ACL nnimap-server-buffer) - (imap-mailbox-acl-get (nnimap-decode-group-name mailbox) - nnimap-server-buffer)))) +(defun nnimap-fetch-inbox (articles) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges articles) + (format "(UID %s%s)" + (format + (if (member "IMAP4REV1" + (nnimap-capabilities nnimap-object)) + "BODY.PEEK[HEADER] BODY.PEEK" + "RFC822.PEEK")) + (if nnimap-split-download-body-default + "[]" + "[1]"))) + t)) -(defun nnimap-acl-edit (mailbox method old-acls new-acls) - (when (nnimap-possibly-change-server (cadr method)) - (unless (imap-capability 'ACL nnimap-server-buffer) - (error "Your server does not support ACL editing")) - (with-current-buffer nnimap-server-buffer - ;; delete all removed identifiers - (mapc (lambda (old-acl) - (unless (assoc (car old-acl) new-acls) - (or (imap-mailbox-acl-delete (car old-acl) - (nnimap-decode-group-name mailbox)) - (error "Can't delete ACL for %s" (car old-acl))))) - old-acls) - ;; set all changed acl's - (mapc (lambda (new-acl) - (let ((new-rights (cdr new-acl)) - (old-rights (cdr (assoc (car new-acl) old-acls)))) - (unless (and old-rights new-rights - (string= old-rights new-rights)) - (or (imap-mailbox-acl-set (car new-acl) new-rights - (nnimap-decode-group-name mailbox)) - (error "Can't set ACL for %s to %s" (car new-acl) - new-rights))))) - new-acls) - t))) +(defun nnimap-split-incoming-mail () + (with-current-buffer (nnimap-buffer) + (let ((nnimap-incoming-split-list nil) + (nnmail-split-methods nnimap-split-methods) + (nnmail-inhibit-default-split-group t) + (groups (nnimap-get-groups)) + new-articles) + (erase-buffer) + (nnimap-command "SELECT %S" nnimap-inbox) + (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*"))) + (when new-articles + (nnimap-fetch-inbox new-articles) + (nnimap-transform-split-mail) + (nnheader-ms-strip-cr) + (nnmail-cache-open) + (nnmail-split-incoming (current-buffer) + #'nnimap-save-mail-spec + nil nil + #'nnimap-dummy-active-number) + (when nnimap-incoming-split-list + (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list)) + sequences) + ;; Create any groups that doesn't already exist on the + ;; server first. + (dolist (spec specs) + (unless (member (car spec) groups) + (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) + ;; Then copy over all the messages. + (erase-buffer) + (dolist (spec specs) + (let ((group (car spec)) + (ranges (cdr spec))) + (push (list (nnimap-send-command "UID COPY %s %S" + (nnimap-article-ranges ranges) + (utf7-encode group t)) + ranges) + sequences))) + ;; Wait for the last COPY response... + (when sequences + (nnimap-wait-for-response (caar sequences)) + ;; And then mark the successful copy actions as deleted, + ;; and possibly expunge them. + (nnimap-mark-and-expunge-incoming + (nnimap-parse-copied-articles sequences))))))))) - -;;; Internal functions - -;; -;; This is confusing. -;; -;; mark => read, tick, draft, reply etc -;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc -;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc -;; -;; Mark should not really contain 'read since it's not a "mark" in the Gnus -;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). -;; +(defun nnimap-mark-and-expunge-incoming (range) + (when range + (setq range (nnimap-article-ranges range)) + (let ((sequence + (nnimap-send-command + "UID STORE %s +FLAGS.SILENT (\\Deleted)" range))) + (cond + ;; If the server supports it, we now delete the message we have + ;; just copied over. + ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (setq sequence (nnimap-send-command "UID EXPUNGE %s" range))) + ;; If it doesn't support UID EXPUNGE, then we only expunge if the + ;; user has configured it. + (nnimap-expunge-inbox + (setq sequence (nnimap-send-command "EXPUNGE")))) + (nnimap-wait-for-response sequence)))) -(defconst nnimap-mark-to-predicate-alist - (mapcar - (lambda (pair) ; cdr is the mark - (or (assoc (cdr pair) - '((read . "SEEN") - (tick . "FLAGGED") - (draft . "DRAFT") - (recent . "RECENT") - (reply . "ANSWERED"))) - (cons (cdr pair) - (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) - (cons '(read . read) gnus-article-mark-lists))) +(defun nnimap-parse-copied-articles (sequences) + (let (sequence copied range) + (goto-char (point-min)) + (while (re-search-forward "^\\([0-9]+\\) OK " nil t) + (setq sequence (string-to-number (match-string 1))) + (when (setq range (cadr (assq sequence sequences))) + (push (gnus-uncompress-range range) copied))) + (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) -(defun nnimap-mark-to-predicate (pred) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate. -This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\", -to be used within a IMAP SEARCH query." - (cdr (assq pred nnimap-mark-to-predicate-alist))) +(defun nnimap-new-articles (flags) + (let (new) + (dolist (elem flags) + (when (or (null (cdr elem)) + (and (not (member "\\Deleted" (cdr elem))) + (not (member "\\Seen" (cdr elem))))) + (push (car elem) new))) + (gnus-compress-sequence (nreverse new)))) + +(defun nnimap-make-split-specs (list) + (let ((specs nil) + entry) + (dolist (elem list) + (destructuring-bind (article spec) elem + (dolist (group (delete nil (mapcar #'car spec))) + (unless (setq entry (assoc group specs)) + (push (setq entry (list group)) specs)) + (setcdr entry (cons article (cdr entry)))))) + (dolist (entry specs) + (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<)))) + specs)) -(defconst nnimap-mark-to-flag-alist - (mapcar - (lambda (pair) - (or (assoc (cdr pair) - '((read . "\\Seen") - (tick . "\\Flagged") - (draft . "\\Draft") - (recent . "\\Recent") - (reply . "\\Answered"))) - (cons (cdr pair) - (format "gnus-%s" (symbol-name (cdr pair)))))) - (cons '(read . read) gnus-article-mark-lists))) - -(defun nnimap-mark-to-flag-1 (preds) - (if (and (not (null preds)) (listp preds)) - (cons (nnimap-mark-to-flag (car preds)) - (nnimap-mark-to-flag (cdr preds))) - (cdr (assoc preds nnimap-mark-to-flag-alist)))) +(defun nnimap-transform-split-mail () + (goto-char (point-min)) + (let (article bytes) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1) + bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + ;; Insert MMDF separator, and a way to remember what this + ;; article UID is. + (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article)) + (forward-char (1+ bytes)) + (setq bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + (forward-char (1+ bytes)) + (delete-region (line-beginning-position) (line-end-position)))))) -(defun nnimap-mark-to-flag (preds &optional always-list make-string) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag. -This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to -be used in a STORE FLAGS command." - (let ((result (nnimap-mark-to-flag-1 preds))) - (setq result (if (and (or make-string always-list) - (not (listp result))) - (list result) - result)) - (if make-string - (mapconcat (lambda (flag) - (if (listp flag) - (mapconcat 'identity flag " ") - flag)) - result " ") - result))) +(defun nnimap-dummy-active-number (group &optional server) + 1) -(defun nnimap-mark-permanent-p (mark &optional group) - "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." - (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) +(defun nnimap-save-mail-spec (group-art &optional server full-nov) + (let (article) + (goto-char (point-min)) + (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t)) + (error "Invalid nnimap mail") + (setq article (string-to-number (match-string 1)))) + (push (list article group-art) + nnimap-incoming-split-list))) (provide 'nnimap)
--- a/lisp/gnus/nnir.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnir.el Wed Sep 22 15:46:51 2010 +0900 @@ -733,7 +733,7 @@ ;; Just set the server variables appropriately. (nnoo-change-server 'nnir server definitions)) -(deffoo nnir-request-group (group &optional server fast) +(deffoo nnir-request-group (group &optional server fast info) "GROUP is the query string." (nnir-possibly-change-server server) ;; Check for cache and return that if appropriate. @@ -744,8 +744,7 @@ nnir-artlist ;; Cache miss. (setq nnir-artlist (nnir-run-query group))) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (if (zerop (length nnir-artlist)) (progn (setq nnir-current-query nil
--- a/lisp/gnus/nnmail.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnmail.el Wed Sep 22 15:46:51 2010 +0900 @@ -614,6 +614,7 @@ (defvar nnmail-split-tracing nil) (defvar nnmail-split-trace nil) +(defvar nnmail-inhibit-default-split-group nil) @@ -674,8 +675,7 @@ "Returns an assoc of group names and active ranges. nn*-request-list should have been called before calling this function." ;; Go through all groups from the active list. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (nnmail-parse-active))) (defun nnmail-parse-active () @@ -1058,7 +1058,9 @@ (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." +FUNC will be called with the buffer narrowed to each mail. +INCOMING can also be a buffer object. In that case, the mail +will be copied over from that buffer." (let ( ;; If this is a group-specific split, we bind the split ;; methods to just this group. (nnmail-split-methods (if (and group @@ -1066,12 +1068,13 @@ (list (list group "")) nnmail-split-methods)) (nnmail-group-names-not-encoded-p t)) - (save-excursion - ;; Insert the incoming file. - (set-buffer (get-buffer-create nnmail-article-buffer)) + ;; Insert the incoming file. + (with-current-buffer (get-buffer-create nnmail-article-buffer) (erase-buffer) - (let ((coding-system-for-read nnmail-incoming-coding-system)) - (mm-insert-file-contents incoming)) + (if (bufferp incoming) + (insert-buffer-substring incoming) + (let ((coding-system-for-read nnmail-incoming-coding-system)) + (mm-insert-file-contents incoming))) (prog1 (if (zerop (buffer-size)) 0 @@ -1100,15 +1103,15 @@ (obuf (current-buffer)) group-art method grp) (if (and (sequencep methods) - (= (length methods) 1)) + (= (length methods) 1) + (not nnmail-inhibit-default-split-group)) ;; If there is only just one group to put everything in, we ;; just return a list with just this one method in. (setq group-art (list (cons (caar methods) (funcall func (caar methods))))) ;; We do actual comparison. - (save-excursion - ;; Copy the article into the work buffer. - (set-buffer nntp-server-buffer) + ;; Copy the article into the work buffer. + (with-current-buffer nntp-server-buffer (erase-buffer) (insert-buffer-substring obuf) ;; Narrow to headers. @@ -1149,7 +1152,8 @@ ;; just call this function here and use the ;; result. (or (funcall nnmail-split-methods) - '("bogus")) + (and (not nnmail-inhibit-default-split-group) + '("bogus"))) (error (nnheader-message 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info) @@ -1194,12 +1198,14 @@ group-art)) ;; This is the final group, which is used as a ;; catch-all. - (unless group-art + (when (and (not group-art) + (not nnmail-inhibit-default-split-group)) (setq group-art (list (cons (car method) (funcall func (car method)))))))) ;; Fall back on "bogus" if all else fails. - (unless group-art + (when (and (not group-art) + (not nnmail-inhibit-default-split-group)) (setq group-art (list (cons "bogus" (funcall func "bogus")))))) ;; Produce a trace if non-empty. (when (and trace nnmail-split-trace) @@ -1572,10 +1578,9 @@ (and nnmail-cache-buffer (buffer-name nnmail-cache-buffer))) () ; The buffer is open. - (save-excursion - (set-buffer + (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*"))) + (get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -1587,8 +1592,7 @@ nnmail-treat-duplicates (buffer-name nnmail-cache-buffer) (buffer-modified-p nnmail-cache-buffer)) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer ;; Weed out the excess number of Message-IDs. (goto-char (point-max)) (when (search-backward "\n" nil t nnmail-message-id-cache-length) @@ -1623,8 +1627,7 @@ ;; pass the first (of possibly >1) group which matches. -Josh (unless (gnus-buffer-live-p nnmail-cache-buffer) (nnmail-cache-open)) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (if (and grp (not (string= "" grp)) (gnus-methods-equal-p gnus-command-method @@ -1657,8 +1660,7 @@ ;; cache. (defun nnmail-cache-fetch-group (id) (when (and nnmail-treat-duplicates nnmail-cache-buffer) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (when (search-backward id nil t) (beginning-of-line) @@ -1702,8 +1704,7 @@ (defun nnmail-cache-id-exists-p (id) (when nnmail-treat-duplicates - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (search-backward id nil t)))) @@ -1857,9 +1858,12 @@ (run-hooks 'nnmail-post-get-new-mail-hook)))) (defun nnmail-expired-article-p (group time force &optional inhibit) - "Say whether an article that is TIME old in GROUP should be expired." + "Say whether an article that is TIME old in GROUP should be expired. +If TIME is nil, then return the cutoff time for oldness instead." (if force - t + (if (null time) + (current-time) + t) (let ((days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait))) @@ -1870,14 +1874,18 @@ nil) ((eq days 'immediate) ;; We expire all articles on sight. - t) + (if (null time) + (current-time) + t)) ((equal time '(0 0)) ;; This is an ange-ftp group, and we don't have any dates. nil) ((numberp days) (setq days (days-to-time days)) ;; Compare the time with the current time. - (ignore-errors (time-less-p days (time-since time)))))))) + (if (null time) + (time-subtract (current-time) days) + (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article))
--- a/lisp/gnus/nnmaildir.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnmaildir.el Wed Sep 22 15:46:51 2010 +0900 @@ -208,20 +208,16 @@ (eval param)) (defmacro nnmaildir--with-nntp-buffer (&rest body) - `(save-excursion - (set-buffer nntp-server-buffer) + `(with-current-buffer nntp-server-buffer ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir work*")) + `(with-current-buffer (get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir nov*")) + `(with-current-buffer (get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir move*")) + `(with-current-buffer (get-buffer-create " *nnmaildir move*") ,@body)) (defmacro nnmaildir--subdir (dir subdir) @@ -987,7 +983,7 @@ (setf (nnmaildir--grp-mmth group) new-mmth) info))) -(defun nnmaildir-request-group (gname &optional server fast) +(defun nnmaildir-request-group (gname &optional server fast info) (let ((group (nnmaildir--prepare server gname)) deactivate-mark) (catch 'return @@ -1249,8 +1245,7 @@ (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) - (save-excursion - (set-buffer (or to-buffer nntp-server-buffer)) + (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (nnheader-insert-file-contents nnmaildir-article-file-name)) (cons gname num-msgid)))) @@ -1289,8 +1284,7 @@ (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " tmpfile)) (throw 'return nil)) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl)) (unix-sync) ;; no fsync :(
--- a/lisp/gnus/nnmairix.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnmairix.el Wed Sep 22 15:46:51 2010 +0900 @@ -424,7 +424,7 @@ (setq nnmairix-current-server server) (nnoo-change-server 'nnmairix server definitions)) -(deffoo nnmairix-request-group (group &optional server fast) +(deffoo nnmairix-request-group (group &optional server fast info) ;; Call mairix and request group on back end server (when server (nnmairix-open-server server)) (let* ((qualgroup (if server @@ -445,8 +445,7 @@ nil) ((not query) ;; No query -> return empty group - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert (concat "211 0 1 0 " group)) t)) @@ -501,9 +500,9 @@ (nnmairix-request-group-with-article-number-correction folder qualgroup))) ((and (= rval 1) - (save-excursion (set-buffer nnmairix-mairix-output-buffer) - (goto-char (point-min)) - (looking-at "^Matched 0 messages"))) + (with-current-buffer nnmairix-mairix-output-buffer + (goto-char (point-min)) + (looking-at "^Matched 0 messages"))) ;; No messages found -> return empty group (nnheader-message 5 "Mairix: No matches found.") (set-buffer nntp-server-buffer) @@ -584,8 +583,7 @@ (when server (nnmairix-open-server server)) (if (nnmairix-call-backend "request-list" nnmairix-backend-server) (let (cpoint cur qualgroup folder) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (setq cpoint (point)) (while (re-search-forward nnmairix-group-regexp (point-max) t) @@ -699,8 +697,7 @@ (when (or (eq nnmairix-propagate-marks-upon-close t) (and (eq nnmairix-propagate-marks-upon-close 'ask) (y-or-n-p "Propagate marks to original articles? "))) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (nnmairix-propagate-marks) ;; update mairix group (gnus-group-jump-to-group qualgroup) @@ -998,8 +995,7 @@ (if server (if (gnus-buffer-live-p gnus-article-buffer) (progn - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq mid (message-fetch-field "Message-ID"))) (while (string-match "[<>]" mid) @@ -1021,8 +1017,7 @@ (if server (if (gnus-buffer-live-p gnus-article-buffer) (progn - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq from (cadr (gnus-extract-address-components (gnus-fetch-field "From")))) @@ -1046,8 +1041,7 @@ (when (nnmairix-call-backend "request-list" nnmairix-backend-server) (let (cur qualgroup folder) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (while (re-search-forward nnmairix-group-regexp (point-max) t) (setq cur (match-string 0) @@ -1152,8 +1146,7 @@ (push (list (car ogroup) (list (list number) (nth 1 mid-marks) (nth 2 mid-marks))) number-cache))))) ;; now we set the marks - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (nnheader-message 5 "nnmairix: Propagating marks...") (dolist (cur number-cache) (setq method (gnus-find-method-for-group (car cur))) @@ -1272,9 +1265,8 @@ "Call mairix binary with COMMAND, using FOLDER and SEARCHQUERY. If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) - (save-excursion - (set-buffer - (get-buffer-create nnmairix-mairix-output-buffer)) + (with-current-buffer + (get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1291,9 +1283,8 @@ (defun nnmairix-call-mairix-binary-raw (command query) "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) - (save-excursion - (set-buffer - (get-buffer-create nnmairix-mairix-output-buffer)) + (with-current-buffer + (get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1430,8 +1421,7 @@ (corr (not (zerop numc))) (name (buffer-name nntp-server-buffer)) header cur xref) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (set-buffer nntp-server-buffer) (goto-char (point-min)) @@ -1621,8 +1611,7 @@ (let ((server (nth 1 gnus-current-select-method)) mid rval group allgroups) ;; get message id - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq mid (message-fetch-field "Message-ID")) ;; first check the registry (if available) @@ -1678,8 +1667,7 @@ (if (zerop (nnmairix-call-mairix-binary-raw (split-string nnmairix-mairix-command) (list (concat "m:" mid)))) - (save-excursion - (set-buffer nnmairix-mairix-output-buffer) + (with-current-buffer nnmairix-mairix-output-buffer (goto-char (point-min)) (while (re-search-forward "^/.*$" nil t) (push (nnmairix-get-group-from-file-path (match-string 0))
--- a/lisp/gnus/nnmbox.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnmbox.el Wed Sep 22 15:46:51 2010 +0900 @@ -79,8 +79,7 @@ (nnoo-define-basics nnmbox) (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length sequence)) (count 0) @@ -149,8 +148,7 @@ (deffoo nnmbox-request-article (article &optional newsgroup server buffer) (nnmbox-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (when (nnmbox-find-article article) (let (start stop) (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) @@ -174,7 +172,7 @@ (cons nnmbox-current-group article) (nnmbox-article-group-number nil))))))) -(deffoo nnmbox-request-group (group &optional server dont-check) +(deffoo nnmbox-request-group (group &optional server dont-check info) (nnmbox-possibly-change-newsgroup nil server) (let ((active (cadr (assoc group nnmbox-group-alist)))) (cond @@ -208,8 +206,7 @@ (nnmail-get-new-mail 'nnmbox (lambda () - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (nnmbox-save-buffer))) (file-name-directory nnmbox-mbox-file) group @@ -253,8 +250,7 @@ rest) (nnmail-activate 'nnmbox) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (while (and articles is-old) (when (nnmbox-find-article (car articles)) (if (setq is-old @@ -292,8 +288,7 @@ result) (and (nnmbox-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) @@ -364,8 +359,7 @@ (deffoo nnmbox-request-replace-article (article group buffer) (nnmbox-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) @@ -391,8 +385,7 @@ ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) @@ -412,8 +405,7 @@ (deffoo nnmbox-request-rename-group (group new-name &optional server) (nnmbox-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -633,8 +625,7 @@ (nnmbox-create-mbox) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) () (save-excursion
--- a/lisp/gnus/nnmh.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnmh.el Wed Sep 22 15:46:51 2010 +0900 @@ -149,7 +149,7 @@ (save-excursion (nnmail-find-file file)) (string-to-number (file-name-nondirectory file))))) -(deffoo nnmh-request-group (group &optional server dont-check) +(deffoo nnmh-request-group (group &optional server dont-check info) (nnheader-init-server-buffer) (nnmh-possibly-change-directory group server) (let ((pathname (nnmail-group-pathname group nnmh-directory))
--- a/lisp/gnus/nnml.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnml.el Wed Sep 22 15:46:51 2010 +0900 @@ -160,8 +160,7 @@ (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) (when (nnml-possibly-change-directory group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((file nil) (number (length sequence)) @@ -255,7 +254,7 @@ (cons (if group-num (car group-num) group) (string-to-number (file-name-nondirectory path))))))) -(deffoo nnml-request-group (group &optional server dont-check) +(deffoo nnml-request-group (group &optional server dont-check info) (let ((file-name-coding-system nnmail-pathname-coding-system) (decoded (nnml-decoded-group-name group server))) (cond @@ -405,8 +404,7 @@ (let (nnml-current-directory nnml-current-group nnml-article-file-alist) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) @@ -462,8 +460,7 @@ (deffoo nnml-request-replace-article (article group buffer) (nnml-possibly-change-directory group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (nnml-possibly-create-directory group) (let ((chars (nnmail-insert-lines)) (art (concat (int-to-string article) "\t")) @@ -478,8 +475,7 @@ t) (setq headers (nnml-parse-head chars article)) ;; Replace the NOV line in the NOV file. - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (goto-char (point-min)) (if (or (looking-at art) (search-forward (concat "\n" art) nil t)) @@ -614,8 +610,7 @@ ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (save-excursion - (set-buffer (get-buffer-create " *nnml id*")) + (with-current-buffer (get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -657,8 +652,7 @@ nil (let ((nov (expand-file-name nnml-nov-file-name nnml-current-directory))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -804,16 +798,14 @@ (defun nnml-add-incremental-nov (group article headers) "Add a nov line for the GROUP nov headers, incrementally." - (save-excursion - (set-buffer (nnml-open-incremental-nov group)) + (with-current-buffer (nnml-open-incremental-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) (defun nnml-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -844,8 +836,7 @@ "") decoded))) (file-name-coding-system nnmail-pathname-coding-system)) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) (erase-buffer) @@ -887,6 +878,7 @@ ;; Save the active file. (nnmail-save-active nnml-group-alist nnml-active-file)) +(defvar nnml-files) (defun nnml-generate-nov-databases-directory (dir &optional seen no-active) "Regenerate the NOV database in DIR. @@ -906,9 +898,9 @@ (file-directory-p dir)) (nnml-generate-nov-databases-directory dir seen))) ;; Do this directory. - (let ((files (sort (nnheader-article-to-file-alist dir) + (let ((nnml-files (sort (nnheader-article-to-file-alist dir) 'car-less-than-car))) - (if (not files) + (if (not nnml-files) (let* ((group (nnheader-file-to-group (directory-file-name dir) nnml-directory)) (info (cadr (assoc group nnml-group-alist)))) @@ -916,11 +908,10 @@ (setcar info (1+ (cdr info))))) (funcall nnml-generate-active-function dir) ;; Generate the nov file. - (nnml-generate-nov-file dir files) + (nnml-generate-nov-file dir nnml-files) (unless no-active (nnmail-save-active nnml-group-alist nnml-active-file))))))) -(defvar files) (defun nnml-generate-active-info (dir) ;; Update the active info for this group. (let ((group (directory-file-name dir)) @@ -931,9 +922,9 @@ last (or (caadr entry) 0) nnml-group-alist (delq entry nnml-group-alist)) (push (list group - (cons (or (caar files) (1+ last)) + (cons (or (caar nnml-files) (1+ last)) (max last - (or (caar (last files)) + (or (caar (last nnml-files)) 0)))) nnml-group-alist))) @@ -942,42 +933,38 @@ (nov (concat dir nnml-nov-file-name)) (nov-buffer (get-buffer-create " *nov*")) chars file headers) - (save-excursion + (with-current-buffer nov-buffer ;; Init the nov buffer. - (set-buffer nov-buffer) (buffer-disable-undo) (erase-buffer) (set-buffer nntp-server-buffer) ;; Delete the old NOV file. (when (file-exists-p nov) (funcall nnmail-delete-file-function nov)) - (while files - (unless (file-directory-p (setq file (concat dir (cdar files)))) - (erase-buffer) - (nnheader-insert-file-contents file) - (narrow-to-region - (goto-char (point-min)) - (progn - (re-search-forward "\n\r?\n" nil t) - (setq chars (- (point-max) (point))) - (max (point-min) (1- (point))))) - (unless (zerop (buffer-size)) - (goto-char (point-min)) - (setq headers (nnml-parse-head chars (caar files))) - (save-excursion - (set-buffer nov-buffer) - (goto-char (point-max)) - (nnheader-insert-nov headers))) - (widen)) - (setq files (cdr files))) - (save-excursion - (set-buffer nov-buffer) + (dolist (file files) + (let ((path (concat dir (cdr file)))) + (unless (file-directory-p path) + (erase-buffer) + (nnheader-insert-file-contents path) + (narrow-to-region + (goto-char (point-min)) + (progn + (re-search-forward "\n\r?\n" nil t) + (setq chars (- (point-max) (point))) + (max (point-min) (1- (point))))) + (unless (zerop (buffer-size)) + (goto-char (point-min)) + (setq headers (nnml-parse-head chars (car file))) + (with-current-buffer nov-buffer + (goto-char (point-max)) + (nnheader-insert-nov headers))) + (widen)))) + (with-current-buffer nov-buffer (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point))) (when (bobp) @@ -1008,11 +995,9 @@ ;; build list from .overview if available ;; We would use nnml-open-nov, except that nnml-nov-buffer-alist is ;; defvoo'd, and we might get called when it hasn't been swapped in. - (save-excursion + (with-current-buffer (nnml-get-nov-buffer nnml-current-group) (let ((list nil) - art - (buffer (nnml-get-nov-buffer nnml-current-group))) - (set-buffer buffer) + art) (goto-char (point-min)) (while (not (eobp)) (setq art (read (current-buffer))) @@ -1031,11 +1016,9 @@ nnml-current-directory)))) (nnheader-article-to-file-alist nnml-current-directory) ;; build list from .overview if available - (save-excursion + (with-current-buffer (nnml-get-nov-buffer nnml-current-group) (let ((alist nil) - (buffer (nnml-get-nov-buffer nnml-current-group)) art) - (set-buffer buffer) (goto-char (point-min)) (while (not (eobp)) (setq art (read (current-buffer))) @@ -1260,8 +1243,7 @@ (gnus-info-set-marks info newmarks)) ;; 3/ Update the NOV entry for this article: (unless nnml-nov-is-evil - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (when (nnheader-find-nov-line old-number) ;; Replace the article number: (looking-at old-number-string)
--- a/lisp/gnus/nnnil.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnnil.el Wed Sep 22 15:46:51 2010 +0900 @@ -56,10 +56,9 @@ (setq nnnil-status-string "No such group") nil) -(defun nnnil-request-group (group &optional server fast) +(defun nnnil-request-group (group &optional server fast info) (let (deactivate-mark) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert "411 no such news group\n"))) (setq nnnil-status-string "No such group")
--- a/lisp/gnus/nnrss.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnrss.el Wed Sep 22 15:46:51 2010 +0900 @@ -134,8 +134,7 @@ (setq group (nnrss-decode-group-name group)) (nnrss-possibly-change-group group server) (let (e) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (article articles) (if (setq e (assq article nnrss-group-data)) @@ -179,7 +178,7 @@ "\n"))))) 'nov) -(deffoo nnrss-request-group (group &optional server dont-check) +(deffoo nnrss-request-group (group &optional server dont-check info) (setq group (nnrss-decode-group-name group)) (nnheader-message 6 "nnrss: Requesting %s..." group) (nnrss-possibly-change-group group server) @@ -342,11 +341,6 @@ ;; we return the article number. (cons nnrss-group (car e)))))) -(deffoo nnrss-request-list (&optional server) - (nnrss-possibly-change-group nil server) - (nnrss-generate-active) - t) - (deffoo nnrss-open-server (server &optional defs connectionless) (nnrss-read-server-data server) (nnoo-change-server 'nnrss server defs) @@ -389,14 +383,24 @@ (deffoo nnrss-request-list-newsgroups (&optional server) (nnrss-possibly-change-group nil server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (elem nnrss-group-alist) (if (third elem) (insert (car elem) "\t" (third elem) "\n")))) t) +(deffoo nnrss-retrieve-groups (groups &optional server) + (nnrss-possibly-change-group nil server) + (dolist (group groups) + (nnrss-check-group group server)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group groups) + (let ((elem (assoc group nnrss-server-data))) + (insert (format "%S %s 1 y\n" group (or (cadr elem) 0))))) + 'active)) + (nnoo-define-skeleton nnrss) ;;; Internal functions @@ -479,20 +483,6 @@ (nnrss-read-group-data group server) (setq nnrss-group group))) -(defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories)) - -(defun nnrss-generate-active () - (when (y-or-n-p "Fetch extra categories? ") - (mapc 'funcall nnrss-extra-categories)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnrss-group-alist) - (insert (prin1-to-string (car elem)) " 0 1 y\n")) - (dolist (elem nnrss-server-data) - (unless (assoc (car elem) nnrss-group-alist) - (insert (prin1-to-string (car elem)) " 0 1 y\n"))))) - (autoload 'timezone-parse-date "timezone") (defun nnrss-normalize-date (date) @@ -868,33 +858,6 @@ (append nnheader-file-name-translation-alist '((?' . ?_))))) (nnheader-translate-file-chars name))) -(defvar nnrss-moreover-url - "http://w.moreover.com/categories/category_list_rss.html" - "The url of moreover.com categories.") - -(defun nnrss-snarf-moreover-categories () - "Snarf RSS links from moreover.com." - (interactive) - (let (category name url changed) - (with-temp-buffer - (nnrss-insert nnrss-moreover-url) - (goto-char (point-min)) - (while (re-search-forward - "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t) - (if (match-string 1) - (setq category (match-string 1)) - (setq url (match-string 2) - name (mm-url-decode-entities-string - (rfc2231-decode-encoded-string - (match-string 3)))) - (if category - (setq name (concat category "." name))) - (unless (assoc name nnrss-server-data) - (setq changed t) - (push (list name 0 url) nnrss-server-data))))) - (if changed - (nnrss-save-server-data "")))) - (defun nnrss-node-text (namespace local-name element) (let* ((node (assq (intern (concat namespace (symbol-name local-name))) element))
--- a/lisp/gnus/nnspool.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnspool.el Wed Sep 22 15:46:51 2010 +0900 @@ -109,8 +109,7 @@ (deffoo nnspool-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (when (nnspool-possibly-change-directory group) (let* ((number (length articles)) @@ -209,8 +208,7 @@ (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (point))) @@ -221,15 +219,14 @@ (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-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)) -(deffoo nnspool-request-group (group &optional server dont-check) +(deffoo nnspool-request-group (group &optional server dont-check info) "Select news GROUP." (let ((pathname (nnspool-article-pathname group)) dir) @@ -343,8 +340,7 @@ ;;; Internal functions. (defun nnspool-inews-sentinel (proc status) - (save-excursion - (set-buffer (process-buffer proc)) + (with-current-buffer (process-buffer proc) (goto-char (point-min)) (if (or (zerop (buffer-size)) (search-forward "spooled" nil t)) @@ -367,8 +363,7 @@ last) (if (not (file-exists-p nov)) () - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if nnspool-sift-nov-with-sed (nnspool-sift-nov-with-sed articles nov)
--- a/lisp/gnus/nntp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nntp.el Wed Sep 22 15:46:51 2010 +0900 @@ -987,7 +987,7 @@ "\r?\n\\.\r?\n" "BODY" (if (numberp article) (int-to-string article) article)))) -(deffoo nntp-request-group (group &optional server dont-check) +(deffoo nntp-request-group (group &optional server dont-check info) (nntp-with-open-group nil server (when (nntp-send-command "^[245].*\n" "GROUP" group) @@ -1014,7 +1014,8 @@ (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) (nnoo-change-server 'nntp server defs) - (unless connectionless + (if connectionless + t (or (nntp-find-connection nntp-server-buffer) (nntp-open-connection nntp-server-buffer)))))
--- a/lisp/gnus/nnvirtual.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnvirtual.el Wed Sep 22 15:46:51 2010 +0900 @@ -93,8 +93,7 @@ (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nnvirtual-possibly-change-server server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if (stringp (car articles)) 'headers @@ -170,8 +169,7 @@ ;; the nntp-server-buffer, which is where Gnus expects to find ;; them. (prog1 - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert-buffer-substring vbuf) ;; FIX FIX FIX, we should be able to sort faster than @@ -215,8 +213,7 @@ (t (setq nnvirtual-last-accessed-component-group cgroup) (if buffer - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer ;; We bind this here to avoid double decoding. (let ((gnus-article-decode-hook nil)) (gnus-request-article-this-buffer (cdr amap) cgroup))) @@ -250,7 +247,7 @@ t))) -(deffoo nnvirtual-request-group (group &optional server dont-check) +(deffoo nnvirtual-request-group (group &optional server dont-check info) (nnvirtual-possibly-change-server server) (setq nnvirtual-component-groups (delete (nnvirtual-current-group) nnvirtual-component-groups)) @@ -335,8 +332,7 @@ (when (not (numberp (gnus-group-unread g))) (gnus-activate-group g))) nnvirtual-component-groups) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-catchup-current nil all)))))
--- a/lisp/gnus/nnweb.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/nnweb.el Wed Sep 22 15:46:51 2010 +0900 @@ -104,8 +104,7 @@ (deffoo nnweb-retrieve-headers (articles &optional group server fetch-old) (nnweb-possibly-change-server group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article header) (mm-with-unibyte-current-buffer @@ -125,7 +124,7 @@ (nnweb-write-active) (nnweb-write-overview group))) -(deffoo nnweb-request-group (group &optional server dont-check) +(deffoo nnweb-request-group (group &optional server dont-check info) (nnweb-possibly-change-server group server) (unless (or nnweb-ephemeral-p dont-check @@ -147,16 +146,14 @@ (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) + (with-current-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)) + (with-current-buffer (or buffer nntp-server-buffer) (let* ((header (cadr (assq article nnweb-articles))) (url (and header (mail-header-xref header)))) (when (or (and url @@ -185,16 +182,14 @@ (deffoo nnweb-close-server (&optional server) (when (and (nnweb-server-opened server) (gnus-buffer-live-p nnweb-buffer)) - (save-excursion - (set-buffer nnweb-buffer) + (with-current-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) + (with-current-buffer nntp-server-buffer (nnmail-generate-active (list (assoc server nnweb-group-alist))) t)) @@ -402,8 +397,7 @@ (defun nnweb-google-create-mapping () "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (erase-buffer) (nnheader-message 7 "Searching google...") (when (funcall (nnweb-definition 'search) nnweb-search) @@ -459,8 +453,7 @@ ;;; (defun nnweb-gmane-create-mapping () "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (let ((case-fold-search t) (active (or (cadr (assoc nnweb-group nnweb-group-alist)) (cons 1 0)))
--- a/lisp/gnus/pop3.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/pop3.el Wed Sep 22 15:46:51 2010 +0900 @@ -129,7 +129,8 @@ (truncate pop3-read-timeout)) 1000)))))) -(defun pop3-streaming-movemail (file) +;;;###autoload +(defun pop3-movemail (file) "Transfer contents of a maildrop to the specified FILE. Use streaming commands." (let* ((process (pop3-open-server pop3-mailhost pop3-port)) @@ -167,7 +168,7 @@ (truncate (/ (buffer-size) 1000)) (truncate (* (/ (* (buffer-size) 1.0) total-size) 100)))) - (nnheader-accept-process-output process))) + (pop3-accept-process-output process))) (defun pop3-write-to-file (file) (let ((pop-buffer (current-buffer)) @@ -227,44 +228,6 @@ (pop3-pass process)) (t (error "Invalid POP3 authentication scheme"))))) -(defun pop3-movemail (&optional crashbox) - "Transfer contents of a maildrop to the specified CRASHBOX." - (or crashbox (setq crashbox (expand-file-name "~/.crashbox"))) - (let* ((process (pop3-open-server pop3-mailhost pop3-port)) - (crashbuf (get-buffer-create " *pop3-retr*")) - (n 1) - message-count - message-sizes) - (pop3-logon process) - (setq message-count (car (pop3-stat process))) - (when (> message-count 0) - (setq message-sizes (pop3-list process))) - (unwind-protect - (while (<= n message-count) - (message "Retrieving message %d of %d from %s... (%.1fk)" - n message-count pop3-mailhost - (/ (cdr (assoc n message-sizes)) - 1024.0)) - (pop3-retr process n crashbuf) - (save-excursion - (set-buffer crashbuf) - (let ((coding-system-for-write 'binary)) - (write-region (point-min) (point-max) crashbox t 'nomesg)) - (set-buffer (process-buffer process)) - (erase-buffer)) - (unless pop3-leave-mail-on-server - (pop3-dele process n)) - (setq n (+ 1 n)) - (pop3-accept-process-output process)) - (when (and pop3-leave-mail-on-server - (> n 1)) - (message "pop3.el doesn't support UIDL. Setting `pop3-leave-mail-on-server' -to %s might not give the result you'd expect." pop3-leave-mail-on-server) - (sit-for 1)) - (pop3-quit process)) - (kill-buffer crashbuf)) - t) - (defun pop3-get-message-count () "Return the number of messages in the maildrop." (let* ((process (pop3-open-server pop3-mailhost pop3-port)) @@ -316,9 +279,9 @@ (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary) process) - (save-excursion - (set-buffer (get-buffer-create (concat " trace of POP session to " - mailhost))) + (with-current-buffer + (get-buffer-create (concat " trace of POP session to " + mailhost)) (erase-buffer) (setq pop3-read-point (point-min)) (setq process @@ -390,8 +353,7 @@ 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)) + (with-current-buffer (process-buffer process) (goto-char pop3-read-point) (while (and (memq (process-status process) '(open run)) (not (search-forward "\r\n" nil t))) @@ -548,8 +510,7 @@ (if msg (string-to-number (nth 2 (split-string response " "))) (let ((start pop3-read-point) end) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (while (not (re-search-forward "^\\.\r\n" nil t)) (pop3-accept-process-output process) (goto-char start)) @@ -567,8 +528,7 @@ (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)) + (with-current-buffer (process-buffer process) (while (not (re-search-forward "^\\.\r\n" nil t)) (pop3-accept-process-output process) (goto-char start)) @@ -584,8 +544,7 @@ (setq end (point-marker)) (pop3-clean-region start end) (pop3-munge-message-separator start end) - (save-excursion - (set-buffer crashbuf) + (with-current-buffer crashbuf (erase-buffer)) (copy-to-buffer crashbuf start end) (delete-region start end) @@ -622,8 +581,7 @@ (pop3-send-command process "QUIT") (pop3-read-response process t) (if process - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (goto-char (point-max)) (delete-process process))))
--- a/lisp/gnus/rfc2047.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/rfc2047.el Wed Sep 22 15:46:51 2010 +0900 @@ -851,18 +851,8 @@ (defun rfc2047-encode-parameter (param value) "Return and PARAM=VALUE string encoded in the RFC2047-like style. -This is a replacement for the `rfc2231-encode-string' function. - -When attaching files as MIME parts, we should use the RFC2231 encoding -to specify the file names containing non-ASCII characters. However, -many mail softwares don't support it in practice and recipients won't -be able to extract files with correct names. Instead, the RFC2047-like -encoding is acceptable generally. This function provides the very -RFC2047-like encoding, resigning to such a regrettable trend. To use -it, put the following line in your ~/.gnus.el file: - -\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) -" +This is a substitution for the `rfc2231-encode-string' function, that +is the standard but many mailers don't support it." (let ((rfc2047-encoding-type 'mime) (rfc2047-encode-max-chars nil)) (rfc2045-encode-string param (rfc2047-encode-string value))))
--- a/lisp/gnus/smime.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/smime.el Wed Sep 22 15:46:51 2010 +0900 @@ -708,8 +708,7 @@ "Go to the SMIME buffer." (interactive) (unless (get-buffer smime-buffer) - (save-excursion - (set-buffer (get-buffer-create smime-buffer)) + (with-current-buffer (get-buffer-create smime-buffer) (smime-mode))) (smime-draw-buffer) (switch-to-buffer smime-buffer))
--- a/lisp/gnus/spam-report.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/spam-report.el Wed Sep 22 15:46:51 2010 +0900 @@ -109,8 +109,7 @@ ;; select this particular article (gnus-summary-select-article nil nil nil article) ;; resend it to the destination address - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (message-resend spam-report-resend-to)))) (defun spam-report-resend-ham (articles) @@ -292,8 +291,7 @@ (gnus-message 7 "Processing requests using `%s'." spam-report-url-ping-function)) (or file (setq file spam-report-requests-file)) - (save-excursion - (set-buffer (find-file-noselect file)) + (with-current-buffer (find-file-noselect file) (goto-char (point-min)) (while (and (not (eobp)) (re-search-forward
--- a/lisp/gnus/spam.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/spam.el Wed Sep 22 15:46:51 2010 +0900 @@ -1605,8 +1605,7 @@ article)))) (defun spam-fetch-article-header (article) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-read-header article) (nth 3 (assq article gnus-newsgroup-data)))) ;;}}} @@ -2172,8 +2171,7 @@ (with-temp-buffer (let ((temp-buffer-name (buffer-name)) (db-param (spam-get-ifile-database-parameter))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (apply 'call-process-region (point-min) (point-max) spam-ifile-program nil temp-buffer-name nil "-c" @@ -2318,9 +2316,8 @@ ;; else, we have a list of addresses here (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) - (save-excursion - (set-buffer - (find-file-noselect file)) + (with-current-buffer + (find-file-noselect file) (dolist (a addresses) (when (stringp a) (goto-char (point-min)) @@ -2521,8 +2518,7 @@ return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (apply 'call-process-region (point-min) (point-max) spam-bogofilter-program @@ -2579,8 +2575,7 @@ (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (let ((status (apply 'call-process-region (point-min) (point-max) @@ -2656,8 +2651,7 @@ (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (apply 'call-process-region (point-min) (point-max) spam-assassin-program nil temp-buffer-name nil spam-spamassassin-arguments)) @@ -2691,8 +2685,7 @@ ;; group the articles into mbox format (dolist (article articles) (let (article-string) - (save-excursion - (set-buffer summary-buffer-name) + (with-current-buffer summary-buffer-name (setq article-string (spam-get-article-as-string article))) (when (stringp article-string) (insert "From \n") ; mbox separator (sa-learn only checks the @@ -2755,8 +2748,7 @@ return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (apply 'call-process-region (point-min) (point-max) spam-bsfilter-program @@ -2841,8 +2833,7 @@ return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) + (with-current-buffer article-buffer-name (apply 'call-process-region (point-min) (point-max) spam-crm114-program
--- a/lisp/gnus/starttls.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/starttls.el Wed Sep 22 15:46:51 2010 +0900 @@ -254,8 +254,7 @@ (starttls-set-process-query-on-exit-flag process nil) (while (and (processp process) (eq (process-status process) 'run) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char old-max) (not (setq done (re-search-forward starttls-connect nil t)))))
--- a/lisp/gnus/utf7.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/gnus/utf7.el Wed Sep 22 15:46:51 2010 +0900 @@ -205,6 +205,7 @@ (mm-decode-coding-region (point-min) (point-max) 'iso-8859-1) (mm-enable-multibyte)) +;;;###autoload (defun utf7-encode (string &optional for-imap) "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
--- a/lisp/help-fns.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/help-fns.el Wed Sep 22 15:46:51 2010 +0900 @@ -645,7 +645,20 @@ ;; inappropriate e.g C-h v <RET> features <RET> ;; (help-xref-on-pp from (point)) (if (< (point) (+ from 20)) - (delete-region (1- from) from))))) + (delete-region (1- from) from)) + (let* ((sv (get variable 'standard-value)) + (origval (and (consp sv) + (condition-case nil + (eval (car sv)) + (error :help-eval-error))))) + (when (and (consp sv) + (not (equal origval val)) + (not (equal origval :help-eval-error))) + (princ "\nOriginal value was \n") + (setq from (point)) + (pp origval) + (if (< (point) (+ from 20)) + (delete-region (1- from) from))))))) (terpri) (when locus
--- a/lisp/ido.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/ido.el Wed Sep 22 15:46:51 2010 +0900 @@ -3403,6 +3403,8 @@ (if default (setq ido-temp-list (cons default (delete default ido-temp-list)))) + (if ido-use-virtual-buffers + (ido-add-virtual-buffers-to-list)) (run-hooks 'ido-make-buffer-list-hook) ido-temp-list))
--- a/lisp/image.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/image.el Wed Sep 22 15:46:51 2010 +0900 @@ -697,21 +697,28 @@ (defcustom imagemagick-types-inhibit '(C HTML HTM TXT PDF) - "Types the imagemagick loader should not try to handle.") + ;; FIXME what are the possible options? + ;; Are these actually file-name extensions? + ;; Why are these upper-case when eg image-types is lower-case? + "Types the ImageMagick loader should not try to handle." + :type '(choice (const :tag "Let ImageMagick handle all the types it can" nil) + (repeat symbol)) + :version "24.1" + :group 'image) ;;;###autoload (defun imagemagick-register-types () - "Register file types that imagemagick is able to handle." + "Register the file types that ImageMagick is able to handle." (let ((im-types (imagemagick-types))) (dolist (im-inhibit imagemagick-types-inhibit) (setq im-types (remove im-inhibit im-types))) (dolist (im-type im-types) (let ((extension (downcase (symbol-name im-type)))) (push - (cons (concat "\\." extension "\\'") 'image-mode) + (cons (concat "\\." extension "\\'") 'image-mode) auto-mode-alist) (push - (cons (concat "\\." extension "\\'") 'imagemagick) + (cons (concat "\\." extension "\\'") 'imagemagick) image-type-file-name-regexps)))))
--- a/lisp/indent.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/indent.el Wed Sep 22 15:46:51 2010 +0900 @@ -68,6 +68,7 @@ but the functions `indent-relative' and `indent-relative-maybe' are special; we don't actually use them here." (interactive) + (syntax-propertize (line-end-position)) (if (memq indent-line-function '(indent-relative indent-relative-maybe)) ;; These functions are used for tabbing, but can't be used for @@ -418,7 +419,7 @@ (goto-char start) (while (< (point) end) (or (and (bolp) (eolp)) - (funcall indent-line-function)) + (indent-according-to-mode)) (forward-line 1)) (move-marker end nil)))) (setq column (prefix-numeric-value column))
--- a/lisp/international/ucs-normalize.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/international/ucs-normalize.el Wed Sep 22 15:46:51 2010 +0900 @@ -100,7 +100,7 @@ ;; D. Sorting and Composition of Smaller Blocks (`ucs-normalize-block-compose-chars') ;; ;; The block will be split to multiple samller blocks by starter -;; charcters. Each block is sorted, and composed if necessary. +;; characters. Each block is sorted, and composed if necessary. ;; ;; E. Composition of Entire Block (`ucs-normalize-compose-chars') ;;
--- a/lisp/isearch.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/isearch.el Wed Sep 22 15:46:51 2010 +0900 @@ -239,7 +239,7 @@ "Face for highlighting Isearch matches." :group 'isearch :group 'basic-faces) -(defvar isearch 'isearch) +(defvar isearch-face 'isearch) (defface isearch-fail '((((class color) (min-colors 88) (background light)) @@ -2537,7 +2537,7 @@ (setq isearch-overlay (make-overlay beg end)) ;; 1001 is higher than lazy's 1000 and ediff's 100+ (overlay-put isearch-overlay 'priority 1001) - (overlay-put isearch-overlay 'face isearch)))) + (overlay-put isearch-overlay 'face isearch-face)))) (defun isearch-dehighlight () (when isearch-overlay
--- a/lisp/language/hebrew.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/language/hebrew.el Wed Sep 22 15:46:51 2010 +0900 @@ -88,14 +88,14 @@ ;; corresponding glyph of FONT-OBJECT. (defun hebrew-font-get-precomposed (font-object) (let ((precomposed (font-get font-object 'hebrew-precomposed)) - ;; Vector of Hebrew precomposed charaters. + ;; Vector of Hebrew precomposed characters. (chars [#xFB2A #xFB2B #xFB2C #xFB2D #xFB2E #xFB2F #xFB30 #xFB31 #xFB32 #xFB33 #xFB34 #xFB35 #xFB36 #xFB38 #xFB39 #xFB3A #xFB3B #xFB3C #xFB3E #xFB40 #xFB41 #xFB43 #xFB44 #xFB46 #xFB47 #xFB48 #xFB49 #xFB4A #xFB4B #xFB4C #xFB4D #xFB4E]) ;; Vector of decomposition character sequences corresponding ;; to the above vector. - (decomposed + (decomposed [[#x05E9 #x05C1] [#x05E9 #x05C2] [#x05E9 #x05BC #x05C1]
--- a/lisp/mail/sendmail.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/mail/sendmail.el Wed Sep 22 15:46:51 2010 +0900 @@ -1096,23 +1096,23 @@ ;; Delete Resent-BCC ourselves (if (save-excursion (beginning-of-line) (looking-at "resent-bcc")) - (delete-region (save-excursion (beginning-of-line) (point)) - (save-excursion (end-of-line) (1+ (point)))))) -;;; Apparently this causes a duplicate Sender. -;;; ;; If the From is different than current user, insert Sender. -;;; (goto-char (point-min)) -;;; (and (re-search-forward "^From:" delimline t) -;;; (progn -;;; (require 'mail-utils) -;;; (not (string-equal -;;; (mail-strip-quoted-names -;;; (save-restriction -;;; (narrow-to-region (point-min) delimline) -;;; (mail-fetch-field "From"))) -;;; (user-login-name)))) -;;; (progn -;;; (forward-line 1) -;;; (insert "Sender: " (user-login-name) "\n"))) + (delete-region (line-beginning-position) + (line-beginning-position 2)))) + ;; Apparently this causes a duplicate Sender. + ;; ;; If the From is different than current user, insert Sender. + ;; (goto-char (point-min)) + ;; (and (re-search-forward "^From:" delimline t) + ;; (progn + ;; (require 'mail-utils) + ;; (not (string-equal + ;; (mail-strip-quoted-names + ;; (save-restriction + ;; (narrow-to-region (point-min) delimline) + ;; (mail-fetch-field "From"))) + ;; (user-login-name)))) + ;; (progn + ;; (forward-line 1) + ;; (insert "Sender: " (user-login-name) "\n"))) ;; Don't send out a blank subject line (goto-char (point-min)) (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) @@ -1179,9 +1179,9 @@ nil errbuf nil "-oi") (and envelope-from (list "-f" envelope-from)) -;;; ;; Don't say "from root" if running under su. -;;; (and (equal (user-real-login-name) "root") -;;; (list "-f" (user-login-name))) + ;; ;; Don't say "from root" if running under su. + ;; (and (equal (user-real-login-name) "root") + ;; (list "-f" (user-login-name))) (and mail-alias-file (list (concat "-oA" mail-alias-file))) (if mail-interactive @@ -1663,6 +1663,7 @@ ;; in middle of loading the file. ;;;###autoload (add-hook 'same-window-buffer-names (purecopy "*mail*")) +;;;###autoload (add-hook 'same-window-buffer-names (purecopy "*unsent mail*")) ;;;###autoload (defun mail (&optional noerase to subject in-reply-to cc replybuffer actions) @@ -1713,48 +1714,48 @@ when the message is sent, we apply FUNCTION to ARGS. This is how Rmail arranges to mark messages `answered'." (interactive "P") -;;; This is commented out because I found it was confusing in practice. -;;; It is easy enough to rename *mail* by hand with rename-buffer -;;; if you want to have multiple mail buffers. -;;; And then you can control which messages to save. --rms. -;;; (let ((index 1) -;;; buffer) -;;; ;; If requested, look for a mail buffer that is modified and go to it. -;;; (if noerase -;;; (progn -;;; (while (and (setq buffer -;;; (get-buffer (if (= 1 index) "*mail*" -;;; (format "*mail*<%d>" index)))) -;;; (not (buffer-modified-p buffer))) -;;; (setq index (1+ index))) -;;; (if buffer (switch-to-buffer buffer) -;;; ;; If none exists, start a new message. -;;; ;; This will never re-use an existing unmodified mail buffer -;;; ;; (since index is not 1 anymore). Perhaps it should. -;;; (setq noerase nil)))) -;;; ;; Unless we found a modified message and are happy, start a new message. -;;; (if (not noerase) -;;; (progn -;;; ;; Look for existing unmodified mail buffer. -;;; (while (and (setq buffer -;;; (get-buffer (if (= 1 index) "*mail*" -;;; (format "*mail*<%d>" index)))) -;;; (buffer-modified-p buffer)) -;;; (setq index (1+ index))) -;;; ;; If none, make a new one. -;;; (or buffer -;;; (setq buffer (generate-new-buffer "*mail*"))) -;;; ;; Go there and initialize it. -;;; (switch-to-buffer buffer) -;;; (erase-buffer) -;;; (setq default-directory (expand-file-name "~/")) -;;; (auto-save-mode auto-save-default) -;;; (mail-mode) -;;; (mail-setup to subject in-reply-to cc replybuffer actions) -;;; (if (and buffer-auto-save-file-name -;;; (file-exists-p buffer-auto-save-file-name)) -;;; (message "Auto save file for draft message exists; consider M-x mail-recover")) -;;; t)) + ;; This is commented out because I found it was confusing in practice. + ;; It is easy enough to rename *mail* by hand with rename-buffer + ;; if you want to have multiple mail buffers. + ;; And then you can control which messages to save. --rms. + ;; (let ((index 1) + ;; buffer) + ;; ;; If requested, look for a mail buffer that is modified and go to it. + ;; (if noerase + ;; (progn + ;; (while (and (setq buffer + ;; (get-buffer (if (= 1 index) "*mail*" + ;; (format "*mail*<%d>" index)))) + ;; (not (buffer-modified-p buffer))) + ;; (setq index (1+ index))) + ;; (if buffer (switch-to-buffer buffer) + ;; ;; If none exists, start a new message. + ;; ;; This will never re-use an existing unmodified mail buffer + ;; ;; (since index is not 1 anymore). Perhaps it should. + ;; (setq noerase nil)))) + ;; ;; Unless we found a modified message and are happy, start a new message. + ;; (if (not noerase) + ;; (progn + ;; ;; Look for existing unmodified mail buffer. + ;; (while (and (setq buffer + ;; (get-buffer (if (= 1 index) "*mail*" + ;; (format "*mail*<%d>" index)))) + ;; (buffer-modified-p buffer)) + ;; (setq index (1+ index))) + ;; ;; If none, make a new one. + ;; (or buffer + ;; (setq buffer (generate-new-buffer "*mail*"))) + ;; ;; Go there and initialize it. + ;; (switch-to-buffer buffer) + ;; (erase-buffer) + ;; (setq default-directory (expand-file-name "~/")) + ;; (auto-save-mode auto-save-default) + ;; (mail-mode) + ;; (mail-setup to subject in-reply-to cc replybuffer actions) + ;; (if (and buffer-auto-save-file-name + ;; (file-exists-p buffer-auto-save-file-name)) + ;; (message "Auto save file for draft message exists; consider M-x mail-recover")) + ;; t)) (if (eq noerase 'new) (pop-to-buffer (generate-new-buffer "*mail*")) @@ -1775,7 +1776,7 @@ (mail-mode) ;; Disconnect the buffer from its visited file ;; (in case the user has actually visited a file *mail*). -;;; (set-visited-file-name nil) + ;; (set-visited-file-name nil) (let (initialized) (and (not (and noerase (not (eq noerase 'new))))
--- a/lisp/makefile.w32-in Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/makefile.w32-in Wed Sep 22 15:46:51 2010 +0900 @@ -55,7 +55,7 @@ # Automatically generated autoload files, apart from lisp/loaddefs.el. LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \ $(lisp)/calendar/diary-loaddefs.el $(lisp)/calendar/hol-loaddefs.el \ - $(lisp)/mh-e/mh-loaddefs.el + $(lisp)/mh-e/mh-loaddefs.el $(lisp)/net/tramp-loaddefs.el AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \ $(lisp)/finder-inf.el $(lisp)/subdirs.el $(lisp)/eshell/esh-groups.el \ @@ -403,6 +403,25 @@ -f w32-batch-update-autoloads \ $(ARGQUOTE)$(lisp)/mh-e/mh-loaddefs.el$(ARGQUOTE) $(MAKE) ./mh-e +# Update TRAMP internal autoloads. Maybe we could move tramp*.el into +# its own subdirectory. OTOH, it does not hurt to keep them in +# lisp/net. +TRAMP_SRC = $(lisp)/net/tramp.el $(lisp)/net/tramp-cache.el \ + $(lisp)/net/tramp-cmds.el $(lisp)/net/tramp-compat.el \ + $(lisp)/net/tramp-ftp.el $(lisp)/net/tramp-gvfs.el \ + $(lisp)/net/tramp-gw.el $(lisp)/net/tramp-imap.el \ + $(lisp)/net/tramp-sh.el $(lisp)/net/tramp-smb.el \ + $(lisp)/net/tramp-uu.el $(lisp)/net/trampver.el + +$(lisp)/net/tramp-loaddefs.el: $(TRAMP_SRC) + "$(EMACS)" $(EMACSOPT) \ + -l autoload \ + --eval $(ARGQUOTE)(setq generate-autoload-cookie $(DQUOTE);;;###tramp-autoload$(DQUOTE))$(ARGQUOTE) \ + --eval $(ARGQUOTE)(setq find-file-suppress-same-file-warnings t)$(ARGQUOTE) \ + --eval $(ARGQUOTE)(setq make-backup-files nil)$(ARGQUOTE) \ + -f w32-batch-update-autoloads \ + $(ARGQUOTE)$(lisp)/net/tramp-loaddefs.el$(ARGQUOTE) $(MAKE) ./net + # Prepare a bootstrap in the lisp subdirectory. # # Build loaddefs.el to make sure it's up-to-date. If it's not, that
--- a/lisp/menu-bar.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/menu-bar.el Wed Sep 22 15:46:51 2010 +0900 @@ -664,13 +664,23 @@ ;; put on a customized-value property. (dolist (elt '(line-number-mode column-number-mode size-indication-mode cua-mode show-paren-mode transient-mark-mode - blink-cursor-mode display-time-mode display-battery-mode)) + blink-cursor-mode display-time-mode display-battery-mode + ;; These are set by other functions that don't set + ;; the customized state. Having them here has the + ;; side-effect that turning them off via X + ;; resources acts like having customized them, but + ;; that seems harmless. + menu-bar-mode tool-bar-mode)) + ;; FIXME ? It's a little annoying that running this command + ;; always loads cua-base, paren, time, and battery, even if they + ;; have not been customized in any way. (Due to custom-load-symbol.) (and (customize-mark-to-save elt) (setq need-save t))) ;; These are set with `customize-set-variable'. (dolist (elt '(scroll-bar-mode debug-on-quit debug-on-error - tooltip-mode menu-bar-mode tool-bar-mode + ;; Somehow this works, when tool-bar and menu-bar don't. + tooltip-mode save-place uniquify-buffer-name-style fringe-mode indicate-empty-lines indicate-buffer-boundaries case-fold-search font-use-system-font @@ -681,7 +691,7 @@ ;; Nonetheless, not saving it would like be confuse ;; more often. ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2002-02-11. - text-mode-hook)) + text-mode-hook tool-bar-position)) (and (get elt 'customized-value) (customize-mark-to-save elt) (setq need-save t))) @@ -971,13 +981,7 @@ (defun menu-bar-set-tool-bar-position (position) (customize-set-variable 'tool-bar-mode t) - (dolist (frame (frame-list)) - (set-frame-parameter frame 'tool-bar-position position)) - (customize-set-variable 'default-frame-alist - (cons (cons 'tool-bar-position position) - (assq-delete-all 'tool-bar-position - default-frame-alist)))) - + (customize-set-variable 'tool-bar-position position)) (defun menu-bar-showhide-tool-bar-menu-customize-disable () "Do not display tool bars." (interactive) @@ -986,7 +990,6 @@ "Display tool bars on the left side." (interactive) (menu-bar-set-tool-bar-position 'left)) - (defun menu-bar-showhide-tool-bar-menu-customize-enable-right () "Display tool bars on the right side." (interactive) @@ -2037,6 +2040,16 @@ (run-with-idle-timer 0 nil 'message "Menu-bar mode disabled. Use M-x menu-bar-mode to make the menu bar appear."))) +;;;###autoload +;; (This does not work right unless it comes after the above definition.) +;; This comment is taken from tool-bar.el near +;; (put 'tool-bar-mode ...) +;; We want to pretend the menu bar by standard is on, as this will make +;; customize consider disabling the menu bar a customization, and save +;; that. We could do this for real by setting :init-value above, but +;; that would overwrite disabling the menu bar from X resources. +(put 'menu-bar-mode 'standard-value '(t)) + (defun toggle-menu-bar-mode-from-frame (&optional arg) "Toggle menu bar on or off, based on the status of the current frame. See `menu-bar-mode' for more information."
--- a/lisp/net/ange-ftp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/ange-ftp.el Wed Sep 22 15:46:51 2010 +0900 @@ -722,6 +722,7 @@ "^Data connection \\|" "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|" "^500 .*AUTH\\|^KERBEROS\\|" + "^504 Unknown security mechanism\\|" "^530 Please login with USER and PASS\\|" ; non kerberised vsFTPd "^534 Kerberos Authentication not enabled\\|" "^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")
--- a/lisp/net/imap.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/imap.el Wed Sep 22 15:46:51 2010 +0900 @@ -448,6 +448,18 @@ The function should take two arguments, the first the IMAP tag and the second the status (OK, NO, BAD etc) of the command.") +(defvar imap-enable-exchange-bug-workaround nil + "Send FETCH UID commands as *:* instead of *. + +When non-nil, use an alternative UIDS form. Enabling appears to +be required for some servers (e.g., Microsoft Exchange 2007) +which otherwise would trigger a response 'BAD The specified +message set is invalid.'. We don't unconditionally use this +form, since this is said to be significantly inefficient. + +This variable is set to t automatically per server if the +canonical form fails.") + ;; Utility functions: @@ -1303,38 +1315,40 @@ ;; Mailbox functions: -(defun imap-mailbox-put (propname value &optional mailbox) - (if imap-mailbox-data - (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) - propname value) - (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" - propname value mailbox (current-buffer))) - t) +(defun imap-mailbox-put (propname value &optional mailbox buffer) + (with-current-buffer (or buffer (current-buffer)) + (if imap-mailbox-data + (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) + propname value) + (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" + propname value mailbox (current-buffer))) + t)) (defsubst imap-mailbox-get-1 (propname &optional mailbox) (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data) propname)) (defun imap-mailbox-get (propname &optional mailbox buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-get-1 propname (or (imap-utf7-encode mailbox) - imap-current-mailbox)))) + (let ((mailbox (imap-utf7-encode mailbox))) + (with-current-buffer (or buffer (current-buffer)) + (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox))))) -(defun imap-mailbox-map-1 (func &optional mailbox-decoder) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (if mailbox-decoder - (funcall mailbox-decoder (symbol-name s)) - (symbol-name s))) result)) - imap-mailbox-data) - result)) +(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) + (with-current-buffer (or buffer (current-buffer)) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (if mailbox-decoder + (funcall mailbox-decoder (symbol-name s)) + (symbol-name s))) result)) + imap-mailbox-data) + result))) -(defun imap-mailbox-map (func) +(defun imap-mailbox-map (func &optional buffer) "Map a function across each mailbox in `imap-mailbox-data', returning a list. Function should take a mailbox name (a string) as the only argument." - (imap-mailbox-map-1 func 'imap-utf7-decode)) + (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) (defun imap-current-mailbox (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1648,26 +1662,29 @@ uids) (imap-message-get uids receive)))))) -(defun imap-message-put (uid propname value) - (if imap-message-data - (put (intern (number-to-string uid) imap-message-data) - propname value) - (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" - uid propname value (current-buffer))) - t) +(defun imap-message-put (uid propname value &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (if imap-message-data + (put (intern (number-to-string uid) imap-message-data) + propname value) + (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" + uid propname value (current-buffer))) + t)) -(defun imap-message-get (uid propname) - (get (intern-soft (number-to-string uid) imap-message-data) - propname)) +(defun imap-message-get (uid propname &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (get (intern-soft (number-to-string uid) imap-message-data) + propname))) -(defun imap-message-map (func propname) +(defun imap-message-map (func propname &optional buffer) "Map a function across each message in `imap-message-data', returning a list." - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (get s 'UID) (get s propname)) result)) - imap-message-data) - result)) + (with-current-buffer (or buffer (current-buffer)) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (get s 'UID) (get s propname)) result)) + imap-message-data) + result))) (defmacro imap-message-envelope-date (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) @@ -1763,6 +1780,48 @@ (format "String %s cannot be converted to a Lisp integer" number)) number))) +(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) + "Like `imap-fetch', but DTRT with Exchange 2007 bug. +However, UIDS here is a cons, where the car is the canonical form +of the UIDS specification, and the cdr is the one which works with +Exchange 2007 or, potentially, other buggy servers. +See `imap-enable-exchange-bug-workaround'." + ;; The first time we get here for a given, we'll try the canonical + ;; form. If we get the known error from the buggy server, set the + ;; flag buffer-locally (to account for connections to multiple + ;; servers), then re-try with the alternative UIDS spec. We don't + ;; unconditionally use the alternative form, since the + ;; currently-used alternatives are seriously inefficient with some + ;; servers (although they are valid). + ;; + ;; FIXME: Maybe it would be cleaner to have a flag to not signal + ;; the error (which otherwise gives a message), and test + ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of + ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:* + ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not + ;; to do the same? + (condition-case data + ;; Binding `debug-on-error' allows us to get the error from + ;; `imap-parse-response' -- it's normally caught by Emacs around + ;; execution of a process filter. + (let ((debug-on-error t)) + (imap-fetch (if imap-enable-exchange-bug-workaround + (cdr uids) + (car uids)) + props receive nouidfetch buffer)) + (error + (if (and (not imap-enable-exchange-bug-workaround) + ;; This is the Exchange 2007 response. It may be more + ;; robust just to check for a BAD response to the + ;; attempted fetch. + (string-match "The specified message set is invalid" + (cadr data))) + (with-current-buffer (or buffer (current-buffer)) + (set (make-local-variable 'imap-enable-exchange-bug-workaround) + t) + (imap-fetch (cdr uids) props receive nouidfetch)) + (signal (car data) (cdr data)))))) + (defun imap-message-copyuid-1 (mailbox) (if (imap-capability 'UIDPLUS) (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) @@ -1772,7 +1831,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch "*:*" "UID") + (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1818,7 +1877,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch "*:*" "UID") + (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -2892,6 +2951,105 @@ (imap-forward) (nreverse body))))) +(when imap-debug ; (untrace-all) + (require 'trace) + (buffer-disable-undo (get-buffer-create imap-debug-buffer)) + (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) + '( + imap-utf7-encode + imap-utf7-decode + imap-error-text + imap-kerberos4s-p + imap-kerberos4-open + imap-ssl-p + imap-ssl-open + imap-network-p + imap-network-open + imap-interactive-login + imap-kerberos4a-p + imap-kerberos4-auth + imap-cram-md5-p + imap-cram-md5-auth + imap-login-p + imap-login-auth + imap-anonymous-p + imap-anonymous-auth + imap-open-1 + imap-open + imap-opened + imap-ping-server + imap-authenticate + imap-close + imap-capability + imap-namespace + imap-send-command-wait + imap-mailbox-put + imap-mailbox-get + imap-mailbox-map-1 + imap-mailbox-map + imap-current-mailbox + imap-current-mailbox-p-1 + imap-current-mailbox-p + imap-mailbox-select-1 + imap-mailbox-select + imap-mailbox-examine-1 + imap-mailbox-examine + imap-mailbox-unselect + imap-mailbox-expunge + imap-mailbox-close + imap-mailbox-create-1 + imap-mailbox-create + imap-mailbox-delete + imap-mailbox-rename + imap-mailbox-lsub + imap-mailbox-list + imap-mailbox-subscribe + imap-mailbox-unsubscribe + imap-mailbox-status + imap-mailbox-acl-get + imap-mailbox-acl-set + imap-mailbox-acl-delete + imap-current-message + imap-list-to-message-set + imap-fetch-asynch + imap-fetch + imap-fetch-safe + imap-message-put + imap-message-get + imap-message-map + imap-search + imap-message-flag-permanent-p + imap-message-flags-set + imap-message-flags-del + imap-message-flags-add + imap-message-copyuid-1 + imap-message-copyuid + imap-message-copy + imap-message-appenduid-1 + imap-message-appenduid + imap-message-append + imap-body-lines + imap-envelope-from + imap-send-command-1 + imap-send-command + imap-wait-for-tag + imap-sentinel + imap-find-next-line + imap-arrival-filter + imap-parse-greeting + imap-parse-response + imap-parse-resp-text + imap-parse-resp-text-code + imap-parse-data-list + imap-parse-fetch + imap-parse-status + imap-parse-acl + imap-parse-flag-list + imap-parse-envelope + imap-parse-body-extension + imap-parse-body + ))) + (provide 'imap) ;;; imap.el ends here
--- a/lisp/net/netrc.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/netrc.el Wed Sep 22 15:46:51 2010 +0900 @@ -54,12 +54,19 @@ "Netrc configuration." :group 'comm) +(defcustom netrc-file "~/.authinfo" + "File where user credentials are stored." + :type 'file + :group 'netrc) + (defvar netrc-services-file "/etc/services" "The name of the services file.") -(defun netrc-parse (file) +(defun netrc-parse (&optional file) (interactive "fFile to Parse: ") "Parse FILE and return a list of all entries in the file." + (unless file + (setq file netrc-file)) (if (listp file) file (when (file-exists-p file) @@ -221,6 +228,20 @@ (eq type (car (cddr service))))))) (cadr service))) +;;;###autoload +(defun netrc-credentials (machine &rest ports) + "Return a user name/password pair. +Port specifications will be prioritised in the order they are +listed in the PORTS list." + (let ((list (netrc-parse)) + found) + (while (and ports + (not found)) + (setq found (netrc-machine list machine (pop ports)))) + (when found + (list (cdr (assoc "login" found)) + (cdr (assoc "password" found)))))) + (provide 'netrc) ;;; netrc.el ends here
--- a/lisp/net/rcirc.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/rcirc.el Wed Sep 22 15:46:51 2010 +0900 @@ -774,42 +774,64 @@ (setq rcirc-input-ring-index (1- rcirc-input-ring-index)) (insert (rcirc-prev-input-string -1)))) -(defvar rcirc-nick-completions nil) -(defvar rcirc-nick-completion-start-offset nil) +(defvar rcirc-server-commands + '("/admin" "/away" "/connect" "/die" "/error" "/info" + "/invite" "/ison" "/join" "/kick" "/kill" "/links" + "/list" "/lusers" "/mode" "/motd" "/names" "/nick" + "/notice" "/oper" "/part" "/pass" "/ping" "/pong" + "/privmsg" "/quit" "/rehash" "/restart" "/service" "/servlist" + "/server" "/squery" "/squit" "/stats" "/summon" "/time" + "/topic" "/trace" "/user" "/userhost" "/users" "/version" + "/wallops" "/who" "/whois" "/whowas") + "A list of user commands by IRC server. +The value defaults to RFCs 1459 and 2812.") + +;; /me and /ctcp are not defined by `defun-rcirc-command'. +(defvar rcirc-client-commands '("/me" "/ctcp") + "A list of user commands defined by IRC client rcirc. +The list is updated automatically by `defun-rcirc-command'.") -(defun rcirc-complete-nick () - "Cycle through nick completions from list of nicks in channel." +(defun rcirc-completion-at-point () + "Function used for `completion-at-point-functions' in `rcirc-mode'." + (let* ((beg (save-excursion + (if (re-search-backward " " rcirc-prompt-end-marker t) + (1+ (point)) + rcirc-prompt-end-marker))) + (table (if (and (= beg rcirc-prompt-end-marker) + (eq (char-after beg) ?/)) + (delete-dups + (nconc + (sort (copy-sequence rcirc-client-commands) 'string-lessp) + (sort (copy-sequence rcirc-server-commands) 'string-lessp))) + (rcirc-channel-nicks (rcirc-buffer-process) rcirc-target)))) + (list beg (point) table))) + +(defvar rcirc-completions nil) +(defvar rcirc-completion-start nil) + +(defun rcirc-complete () + "Cycle through completions from list of nicks in channel or IRC commands. +IRC command completion is performed only if '/' is the first input char." (interactive) (if (eq last-command this-command) - (setq rcirc-nick-completions - (append (cdr rcirc-nick-completions) - (list (car rcirc-nick-completions)))) - (setq rcirc-nick-completion-start-offset - (- (save-excursion - (if (re-search-backward " " rcirc-prompt-end-marker t) - (1+ (point)) - rcirc-prompt-end-marker)) - rcirc-prompt-end-marker)) - (setq rcirc-nick-completions - (let ((completion-ignore-case t)) - (all-completions - (buffer-substring - (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - (point)) - (mapcar (lambda (x) (cons x nil)) - (rcirc-channel-nicks (rcirc-buffer-process) - rcirc-target)))))) - (let ((completion (car rcirc-nick-completions))) + (setq rcirc-completions + (append (cdr rcirc-completions) (list (car rcirc-completions)))) + (let ((completion-ignore-case t) + (table (rcirc-completion-at-point))) + (setq rcirc-completion-start (car table)) + (setq rcirc-completions + (all-completions (buffer-substring rcirc-completion-start + (cadr table)) + (nth 2 table))))) + (let ((completion (car rcirc-completions))) (when completion - (delete-region (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - (point)) - (insert (concat completion - (if (= (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - rcirc-prompt-end-marker) - ": ")))))) + (delete-region rcirc-completion-start (point)) + (insert + (concat completion + (cond + ((= (aref completion 0) ?/) " ") + ((= rcirc-completion-start rcirc-prompt-end-marker) ": ") + (t ""))))))) (defun set-rcirc-decode-coding-system (coding-system) "Set the decode coding system used in this channel." @@ -827,7 +849,7 @@ (define-key rcirc-mode-map (kbd "RET") 'rcirc-send-input) (define-key rcirc-mode-map (kbd "M-p") 'rcirc-insert-prev-input) (define-key rcirc-mode-map (kbd "M-n") 'rcirc-insert-next-input) -(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete-nick) +(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete) (define-key rcirc-mode-map (kbd "C-c C-b") 'rcirc-browse-url) (define-key rcirc-mode-map (kbd "C-c C-c") 'rcirc-edit-multiline) (define-key rcirc-mode-map (kbd "C-c C-j") 'rcirc-cmd-join) @@ -948,6 +970,9 @@ rcirc-buffer-alist)))) (rcirc-update-short-buffer-names)) + (add-hook 'completion-at-point-functions + 'rcirc-completion-at-point nil 'local) + (run-hooks 'rcirc-mode-hook)) (defun rcirc-update-prompt (&optional all) @@ -2004,16 +2029,18 @@ ;; containing the text following the /cmd. (defmacro defun-rcirc-command (command argument docstring interactive-form - &rest body) + &rest body) "Define a command." - `(defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) - (,@argument &optional process target) - ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - ,interactive-form - (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) - ,@body))) + `(progn + (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))) + (defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) + (,@argument &optional process target) + ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + ,interactive-form + (let ((process (or process (rcirc-buffer-process))) + (target (or target rcirc-target))) + ,@body)))) (defun-rcirc-command msg (message) "Send private MESSAGE to TARGET."
--- a/lisp/net/tramp-cache.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-cache.el Wed Sep 22 15:46:51 2010 +0900 @@ -50,24 +50,12 @@ ;;; Code: -;; Pacify byte-compiler. -(eval-when-compile - (require 'cl) - (autoload 'tramp-message "tramp") - (autoload 'tramp-tramp-file-p "tramp") - ;; We cannot autoload macro `with-parsed-tramp-file-name', it - ;; results in problems of byte-compiled code. - (autoload 'tramp-dissect-file-name "tramp") - (autoload 'tramp-file-name-method "tramp") - (autoload 'tramp-file-name-user "tramp") - (autoload 'tramp-file-name-host "tramp") - (autoload 'tramp-file-name-localname "tramp") - (autoload 'tramp-run-real-handler "tramp") - (autoload 'tramp-time-less-p "tramp") - (autoload 'time-stamp-string "time-stamp")) +(require 'tramp) +(autoload 'time-stamp-string "time-stamp") ;;; -- Cache -- +;;;###tramp-autoload (defvar tramp-cache-data (make-hash-table :test 'equal) "Hash table for remote files properties.") @@ -103,6 +91,7 @@ (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload (defun tramp-get-file-property (vec file property default) "Get the PROPERTY of FILE from the cache context of VEC. Returns DEFAULT if not set." @@ -130,6 +119,7 @@ (tramp-message vec 8 "%s %s %s" file property value) value)) +;;;###tramp-autoload (defun tramp-set-file-property (vec file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of VEC. Returns VALUE." @@ -144,6 +134,28 @@ (tramp-message vec 8 "%s %s %s" file property value) value)) +;;;###tramp-autoload +(defmacro with-file-property (vec file property &rest body) + "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. +FILE must be a local file name on a connection identified via VEC." + `(if (file-name-absolute-p ,file) + (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass @body as parameter to + ;; `tramp-set-file-property' because it mangles our + ;; debug messages. + (setq value (progn ,@body)) + (tramp-set-file-property ,vec ,file ,property value)) + value) + ,@body)) + +;;;###tramp-autoload +(put 'with-file-property 'lisp-indent-function 3) +(put 'with-file-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-file-property\\>")) + +;;;###tramp-autoload (defun tramp-flush-file-property (vec file) "Remove all properties of FILE in the cache context of VEC." ;; Unify localname. @@ -152,6 +164,7 @@ (tramp-message vec 8 "%s" file) (remhash vec tramp-cache-data)) +;;;###tramp-autoload (defun tramp-flush-directory-property (vec directory) "Remove all properties of DIRECTORY in the cache context of VEC. Remove also properties of all files in subdirectories." @@ -175,8 +188,7 @@ (buffer-file-name) default-directory))) (when (tramp-tramp-file-p bfn) - (let* ((v (tramp-dissect-file-name bfn)) - (localname (tramp-file-name-localname v))) + (with-parsed-tramp-file-name bfn nil (tramp-flush-file-property v localname))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) @@ -193,6 +205,7 @@ ;;; -- Properties -- +;;;###tramp-autoload (defun tramp-get-connection-property (key property default) "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a vector. @@ -209,6 +222,7 @@ (tramp-message key 7 "%s %s" property value) value)) +;;;###tramp-autoload (defun tramp-set-connection-property (key property value) "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a vector. @@ -223,14 +237,28 @@ tramp-cache-data)))) (puthash property value hash) (setq tramp-cache-data-changed t) - ;; This function is called also during initialization of - ;; tramp-cache.el. `tramp-message´ is not defined yet at this - ;; time, so we ignore the corresponding error. - (condition-case nil - (tramp-message key 7 "%s %s" property value) - (error nil)) + (tramp-message key 7 "%s %s" property value) value)) +;;;###tramp-autoload +(defmacro with-connection-property (key property &rest body) + "Check in Tramp for property PROPERTY, otherwise executes BODY and set." + `(let ((value (tramp-get-connection-property ,key ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass ,@body as parameter to + ;; `tramp-set-connection-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-connection-property ,key ,property value)) + value)) + +;;;###tramp-autoload +(put 'with-connection-property 'lisp-indent-function 2) +(put 'with-connection-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-connection-property\\>")) + +;;;###tramp-autoload (defun tramp-flush-connection-property (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a vector." @@ -251,6 +279,7 @@ (setq tramp-cache-data-changed t) (remhash key tramp-cache-data)) +;;;###tramp-autoload (defun tramp-cache-print (table) "Print hash table TABLE." (when (hash-table-p table) @@ -271,6 +300,7 @@ table) result))) +;;;###tramp-autoload (defun tramp-list-connections () "Return a list of all known connection vectors according to `tramp-cache'." (let (result) @@ -284,41 +314,40 @@ (defun tramp-dump-connection-properties () "Write persistent connection properties into file `tramp-persistency-file-name'." ;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed. - (condition-case nil - (when (and (hash-table-p tramp-cache-data) - (not (zerop (hash-table-count tramp-cache-data))) - tramp-cache-data-changed - (stringp tramp-persistency-file-name)) - (let ((cache (copy-hash-table tramp-cache-data))) - ;; Remove temporary data. - (maphash - '(lambda (key value) - (if (and (vectorp key) (not (tramp-file-name-localname key))) - (progn - (remhash "process-name" value) - (remhash "process-buffer" value) - (remhash "first-password-request" value)) - (remhash key cache))) - cache) - ;; Dump it. - (with-temp-buffer - (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all (X)Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) - ";; Tramp connection history. Don't change this file.\n" - ";; You can delete it, forcing Tramp to reapply the checks.\n\n" - (with-output-to-string - (pp (read (format "(%s)" (tramp-cache-print cache)))))) - (write-region - (point-min) (point-max) tramp-persistency-file-name)))) - (error nil))) + (ignore-errors + (when (and (hash-table-p tramp-cache-data) + (not (zerop (hash-table-count tramp-cache-data))) + tramp-cache-data-changed + (stringp tramp-persistency-file-name)) + (let ((cache (copy-hash-table tramp-cache-data))) + ;; Remove temporary data. + (maphash + '(lambda (key value) + (if (and (vectorp key) (not (tramp-file-name-localname key))) + (progn + (remhash "process-name" value) + (remhash "process-buffer" value) + (remhash "first-password-request" value)) + (remhash key cache))) + cache) + ;; Dump it. + (with-temp-buffer + (insert + ";; -*- emacs-lisp -*-" + ;; `time-stamp-string' might not exist in all (X)Emacs flavors. + (condition-case nil + (progn + (format + " <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name)) + (error "\n")) + ";; Tramp connection history. Don't change this file.\n" + ";; You can delete it, forcing Tramp to reapply the checks.\n\n" + (with-output-to-string + (pp (read (format "(%s)" (tramp-cache-print cache)))))) + (write-region + (point-min) (point-max) tramp-persistency-file-name)))))) (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties) (add-hook 'tramp-cache-unload-hook @@ -326,6 +355,7 @@ (remove-hook 'kill-emacs-hook 'tramp-dump-connection-properties))) +;;;###tramp-autoload (defun tramp-parse-connection-properties (method) "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' @@ -364,6 +394,10 @@ tramp-persistency-file-name (error-message-string err)) (clrhash tramp-cache-data)))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-cache 'force))) + (provide 'tramp-cache) ;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26
--- a/lisp/net/tramp-cmds.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-cmds.el Wed Sep 22 15:46:51 2010 +0900 @@ -50,6 +50,7 @@ x))) (buffer-list)))) +;;;###tramp-autoload (defun tramp-cleanup-connection (vec) "Flush all connection related objects. This includes password cache, file cache, connection cache, buffers. @@ -129,6 +130,7 @@ ;; Tramp version is useful in a number of situations. +;;;###tramp-autoload (defun tramp-version (arg) "Print version number of tramp.el in minibuffer or current buffer." (interactive "P") @@ -387,6 +389,9 @@ (defalias 'tramp-submit-bug 'tramp-bug) +(add-hook 'tramp-unload-hook + (lambda () (unload-feature 'tramp-cmds 'force))) + (provide 'tramp-cmds) ;;; TODO: @@ -395,7 +400,7 @@ ;; * WIBNI there was an interactive command prompting for Tramp ;; method, hostname, username and filename and translates the user ;; input into the correct filename syntax (depending on the Emacs -;; flavor) (Reiner Steib) +;; flavor) (Reiner Steib) ;; * Let the user edit the connection properties interactively. ;; Something like `gnus-server-edit-server' in Gnus' *Server* buffer. ;; * It's just that when I come to Customize `tramp-default-user-alist' @@ -404,7 +409,7 @@ ;; Option and should not be modified by the code. add-to-list is ;; called in several places. One way to handle that is to have a new ;; ordinary variable that gets its initial value from -;; tramp-default-user-alist and then is added to. (Pete Forman) +;; tramp-default-user-alist and then is added to. (Pete Forman) ;; arch-tag: 190d4c33-76bb-4e99-8b6f-71741f23d98c ;;; tramp-cmds.el ends here
--- a/lisp/net/tramp-compat.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-compat.el Wed Sep 22 15:46:51 2010 +0900 @@ -29,6 +29,8 @@ ;;; Code: +(require 'tramp-loaddefs) + (eval-when-compile ;; Pacify byte-compiler. @@ -36,40 +38,41 @@ (eval-and-compile + (require 'advice) (require 'custom) + (require 'format-spec) + + ;; As long as password.el is not part of (X)Emacs, it shouldn't be + ;; mandatory. + (if (featurep 'xemacs) + (load "password" 'noerror) + (or (require 'password-cache nil 'noerror) + (require 'password nil 'noerror))) ; Part of contrib. + + ;; auth-source is relatively new. + (if (featurep 'xemacs) + (load "auth-source" 'noerror) + (require 'auth-source nil 'noerror)) ;; Load the appropriate timer package. (if (featurep 'xemacs) (require 'timer-funcs) (require 'timer)) - (autoload 'tramp-tramp-file-p "tramp") - (autoload 'tramp-file-name-handler "tramp") - ;; We check whether `start-file-process' is bound. (unless (fboundp 'start-file-process) ;; tramp-util offers integration into other (X)Emacs packages like ;; compile.el, gud.el etc. Not necessary in Emacs 23. (eval-after-load "tramp" - '(progn - (require 'tramp-util) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-util) - (unload-feature 'tramp-util 'force)))))) + '(require 'tramp-util)) ;; Make sure that we get integration with the VC package. When it ;; is loaded, we need to pull in the integration module. Not ;; necessary in Emacs 23. (eval-after-load "vc" (eval-after-load "tramp" - '(progn - (require 'tramp-vc) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-vc) - (unload-feature 'tramp-vc 'force)))))))) + '(require 'tramp-vc)))) ;; Avoid byte-compiler warnings if the byte-compiler supports this. ;; Currently, XEmacs supports this. @@ -93,11 +96,6 @@ (defvar byte-compile-not-obsolete-vars nil)) (setq byte-compile-not-obsolete-vars '(directory-sep-char)) - ;; `with-temp-message' does not exists in XEmacs. - (condition-case nil - (with-temp-message (current-message) nil) - (error (defmacro with-temp-message (message &rest body) `(progn ,@body)))) - ;; For not existing functions, or functions with a changed argument ;; list, there are compiler warnings. We want to avoid them in ;; cases we know what we do. @@ -111,10 +109,6 @@ (unless (fboundp 'set-buffer-multibyte) (defalias 'set-buffer-multibyte 'ignore)) - ;; `font-lock-add-keywords' does not exist in XEmacs. - (unless (fboundp 'font-lock-add-keywords) - (defalias 'font-lock-add-keywords 'ignore)) - ;; The following functions cannot be aliases of the corresponding ;; `tramp-handle-*' functions, because this would bypass the locking ;; mechanism. @@ -187,6 +181,19 @@ 'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards) (ad-activate 'file-expand-wildcards))))) +;; `with-temp-message' does not exists in XEmacs. +(if (fboundp 'with-temp-message) + (defalias 'tramp-compat-with-temp-message 'with-temp-message) + (defmacro tramp-compat-with-temp-message (message &rest body) + "Display MESSAGE temporarily if non-nil while BODY is evaluated." + `(progn ,@body))) + +;; `font-lock-add-keywords' does not exist in XEmacs. +(defun tramp-compat-font-lock-add-keywords (mode keywords &optional how) + "Add highlighting KEYWORDS for MODE." + (ignore-errors + (tramp-compat-funcall 'font-lock-add-keywords mode keywords how))) + (defsubst tramp-compat-line-beginning-position () "Return point at beginning of line (compat function). Calls `line-beginning-position' or `point-at-bol' if defined, else @@ -263,6 +270,24 @@ ;; Default value in XEmacs. (t 134217727))) +(defun tramp-compat-decimal-to-octal (i) + "Return a string consisting of the octal digits of I. +Not actually used. Use `(format \"%o\" i)' instead?" + (cond ((< i 0) (error "Cannot convert negative number to octal")) + ((not (integerp i)) (error "Cannot convert non-integer to octal")) + ((zerop i) "0") + (t (concat (tramp-compat-decimal-to-octal (/ i 8)) + (number-to-string (% i 8)))))) + +;; Kudos to Gerd Moellmann for this suggestion. +(defun tramp-compat-octal-to-decimal (ostr) + "Given a string of octal digits, return a decimal number." + (let ((x (or ostr ""))) + ;; `save-match' is in `tramp-mode-string-to-int' which calls this. + (unless (string-match "\\`[0-7]*\\'" x) + (error "Non-octal junk in string `%s'" x)) + (string-to-number ostr 8))) + ;; ID-FORMAT does not exists in XEmacs. (defun tramp-compat-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files (compat function)." @@ -397,6 +422,20 @@ element is not omitted." (delete "" (split-string string pattern))) +(defun tramp-compat-call-process + (program &optional infile destination display &rest args) + "Calls `call-process' on the local host. +This is needed because for some Emacs flavors Tramp has +defadviced `call-process' to behave like `process-file'. The +Lisp error raised when PROGRAM is nil is trapped also, returning 1." + (let ((default-directory + (if (file-remote-p default-directory) + (tramp-compat-temporary-file-directory) + default-directory))) + (if (executable-find program) + (apply 'call-process program infile destination display args) + 1))) + (defun tramp-compat-process-running-p (process-name) "Returns `t' if system process PROCESS-NAME is running for `user-login-name'." (when (stringp process-name) @@ -439,6 +478,22 @@ (setenv "UNIX95" unix95) result))))) +;; The following functions do not exist in XEmacs. We ignore this; +;; they are used for checking a remote tty. +(defun tramp-compat-process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." + (ignore-errors (tramp-compat-funcall 'process-get process propname))) + +(defun tramp-compat-process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(process-get PROCESS PROPNAME)'." + (ignore-errors (tramp-compat-funcall 'process-put process propname value))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO:
--- a/lisp/net/tramp-fish.el Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1181 +0,0 @@ -;;; tramp-fish.el --- Tramp access functions for FISH protocol - -;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Michael Albinus <michael.albinus@gmx.de> -;; Keywords: comm, processes -;; Package: tramp - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Access functions for FIles transferred over SHell protocol from Tramp. - -;; FISH is a protocol developped for the GNU Midnight Commander -;; <https://savannah.gnu.org/projects/mc>. A client connects to a -;; remote host via ssh (or rsh, shall be configurable), and starts -;; there a fish server via the command "start_fish_server". All -;; commands from the client have the form "#FISH_COMMAND\n" (always -;; one line), followed by equivalent shell commands in case there is -;; no fish server running. - -;; The fish server (or the equivalent shell commands) must return the -;; response, which is finished by a line "### xxx <optional text>\n". -;; "xxx" stands for 3 digits, representing a return code. Return -;; codes "# 000" and "# 001" are reserved for fallback implementation -;; with native shell commands; they are not used inside the server. See -;; <http://cvs.savannah.gnu.org/viewcvs/mc/vfs/README.fish?root=mc&view=markup> -;; for details of original specification. - -;; The GNU Midnight Commander implements the original fish protocol -;; version 0.0.2. The KDE Konqueror has its own implementation, which -;; can be found at -;; <http://websvn.kde.org/branches/KDE/3.5/kdebase/kioslave/fish>. It -;; implements an extended protocol version 0.0.3. Additionally, it -;; provides a fish server implementation in Perl (which is the only -;; implementation I've heard of). The following command reference is -;; based on that implementation. - -;; All commands return either "### 2xx\n" (OK) or "### 5xx <optional text>\n" -;; (NOK). Return codes are mentioned only if they are different from this. -;; Spaces in any parameter must be escaped by "\ ". - -;; Command/Return Code Comment -;; -;; #FISH initial connection, not used -;; in .fishsrv.pl -;; ### 100 transfer fish server missing server, or wrong checksum -;; version 0.0.3 only - -;; #VER a.b.c <commands requested> -;; VER x.y.z <commands offered> .fishsrv.pl response is not uptodate - -;; #PWD -;; /path/to/file - -;; #CWD /some/path - -;; #COPY /path/a /path/b version 0.0.3 only - -;; #RENAME /path/a /path/b - -;; #SYMLINK /path/a /path/b - -;; #LINK /path/a /path/b - -;; #DELE /some/path - -;; #MKD /some/path - -;; #RMD /some/path - -;; #CHOWN user /file/name - -;; #CHGRP group /file/name - -;; #CHMOD 1234 file - -;; #READ <offset> <size> /path/and/filename -;; ### 291 successful exit when reading -;; ended at eof -;; ### 292 successful exit when reading -;; did not end at eof - -;; #WRITE <offset> <size> /path/and/filename - -;; #APPEND <size> /path/and/filename version 0.0.3 only - -;; #LIST /directory -;; <number of entries> version 0.0.3 only -;; ### 100 version 0.0.3 only -;; P<unix permissions> <owner>.<group> -;; S<size> -;; d<3-letters month name> <day> <year or HH:MM> -;; D<year> <month> <day> <hour> <minute> <second>[.1234] -;; E<major-of-device>,<minor> -;; :<filename> -;; L<filename symlink points to> -;; M<mimetype> version 0.0.3 only -;; <blank line to separate items> - -;; #STAT /file version 0.0.3 only -;; like #LIST except for directories -;; <number of entries> -;; ### 100 -;; P<unix permissions> <owner>.<group> -;; S<size> -;; d<3-letters month name> <day> <year or HH:MM> -;; D<year> <month> <day> <hour> <minute> <second>[.1234] -;; E<major-of-device>,<minor> -;; :<filename> -;; L<filename symlink points to> -;; <blank line to separate items> - -;; #RETR /some/name -;; <filesize> -;; ### 100 -;; <binary data> exactly filesize bytes -;; ### 200 with no preceding newline - -;; #STOR <size> /file/name -;; ### 100 -;; <data> exactly size bytes -;; ### 001 partial success - -;; #EXEC <command> <tmpfile> version 0.0.3 only -;; <tmpfile> must not exists. It contains the output of <command>. -;; It can be retrieved afterwards. Last line is -;; ###RESULT: <returncode> - -;; This implementation is meant as proof of the concept, whether there -;; is a better performance compared with the native ssh method. It -;; looks like the file information retrieval is slower, especially the -;; #LIST command. On the other hand, the file contents transmission -;; seems to perform better than other inline methods, because there is -;; no need for data encoding/decoding, and it supports the APPEND -;; parameter of `write-region'. Transfer of binary data fails due to -;; Emacs' process input/output handling. - -;;; Code: - -(eval-when-compile - ;; Pacify byte-compiler. - (require 'cl)) - -(require 'tramp) -(require 'tramp-cache) -(require 'tramp-compat) - -;; Define FISH method ... -(defcustom tramp-fish-method "fish" - "*Method to connect via FISH protocol." - :group 'tramp - :type 'string) - -;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-fish-method nil)) - -;; Add a default for `tramp-default-user-alist'. Default is the local user. -(add-to-list 'tramp-default-user-alist - `(,tramp-fish-method nil ,(user-login-name))) - -;; Add completion function for FISH method. -(tramp-set-completion-function - tramp-fish-method tramp-completion-function-alist-ssh) - -(defconst tramp-fish-continue-prompt-regexp "^### 100.*\n" - "FISH return code OK.") - -;; It cannot be a defconst, occasionally we bind it locally. -(defvar tramp-fish-ok-prompt-regexp "^### 200\n" - "FISH return code OK.") - -(defconst tramp-fish-error-prompt-regexp "^### \\(4\\|5\\)[0-9]+.*\n" - "Regexp for possible error strings of FISH servers. -Used instead of analyzing error codes of commands.") - -(defcustom tramp-fish-start-fish-server-command - (concat "stty intr \"\" quit \"\" erase \"\" kill \"\" eof \"\" eol \"\" eol2 \"\" swtch \"\" start \"\" stop \"\" susp \"\" rprnt \"\" werase \"\" lnext \"\" flush \"\"; " - "perl .fishsrv.pl " - "`grep 'ARGV\\[0\\]' .fishsrv.pl | " - "sed -e 's/^[^\"]*\"//' -e 's/\"[^\"]*$//'`; " - "exit") - "*Command to connect via FISH protocol." - :group 'tramp - :type 'string) - -;; New handlers should be added here. -(defconst tramp-fish-file-name-handler-alist - '( - ;; `access-file' performed by default handler - (add-name-to-file . tramp-fish-handle-add-name-to-file) - ;; `byte-compiler-base-file-name' performed by default handler - (copy-file . tramp-fish-handle-copy-file) - (delete-directory . tramp-fish-handle-delete-directory) - (delete-file . tramp-fish-handle-delete-file) - ;; `diff-latest-backup-file' performed by default handler - (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes . tramp-fish-handle-directory-files-and-attributes) - ;; `dired-call-process' performed by default handler - ;; `dired-compress-file' performed by default handler - (dired-uncache . tramp-handle-dired-uncache) - (expand-file-name . tramp-fish-handle-expand-file-name) - ;; `file-accessible-directory-p' performed by default handler - (file-attributes . tramp-fish-handle-file-attributes) - (file-directory-p . tramp-fish-handle-file-directory-p) - (file-executable-p . tramp-fish-handle-file-executable-p) - (file-exists-p . tramp-fish-handle-file-exists-p) - (file-local-copy . tramp-fish-handle-file-local-copy) - (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-fish-handle-file-name-all-completions) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (file-name-completion . tramp-handle-file-name-completion) - (file-name-directory . tramp-handle-file-name-directory) - (file-name-nondirectory . tramp-handle-file-name-nondirectory) - ;; `file-name-sans-versions' performed by default handler - (file-newer-than-file-p . tramp-fish-handle-file-newer-than-file-p) - (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fish-handle-file-readable-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-remote-p . tramp-handle-file-remote-p) - ;; `file-selinux-context' performed by default handler. - (file-symlink-p . tramp-handle-file-symlink-p) - ;; `file-truename' performed by default handler - (file-writable-p . tramp-fish-handle-file-writable-p) - (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler - ;; `get-file-buffer' performed by default handler - (insert-directory . tramp-fish-handle-insert-directory) - (insert-file-contents . tramp-fish-handle-insert-file-contents) - (load . tramp-handle-load) - (make-directory . tramp-fish-handle-make-directory) - (make-directory-internal . tramp-fish-handle-make-directory-internal) - (make-symbolic-link . tramp-fish-handle-make-symbolic-link) - (rename-file . tramp-fish-handle-rename-file) - (set-file-modes . tramp-fish-handle-set-file-modes) - ;; `set-file-selinux-context' performed by default handler. - (set-file-times . tramp-fish-handle-set-file-times) - (set-visited-file-modtime . ignore) - (shell-command . tramp-handle-shell-command) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (vc-registered . ignore) - (verify-visited-file-modtime . ignore) - (write-region . tramp-fish-handle-write-region) - (executable-find . tramp-fish-handle-executable-find) - (start-file-process . ignore) - (process-file . tramp-fish-handle-process-file) -) - "Alist of handler functions for Tramp FISH method. -Operations not mentioned here will be handled by the default Emacs primitives.") - -(defun tramp-fish-file-name-p (filename) - "Check if it's a filename for FISH protocol." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-fish-method))) - -(defun tramp-fish-file-name-handler (operation &rest args) - "Invoke the FISH related OPERATION. -First arg specifies the OPERATION, second arg is a list of arguments to -pass to the OPERATION." - (let ((fn (assoc operation tramp-fish-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) - -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-fish-file-name-p 'tramp-fish-file-name-handler)) - - -;; File name primitives - -(defun tramp-fish-handle-add-name-to-file - (filename newname &optional ok-if-already-exists) - "Like `add-name-to-file' for Tramp files." - (unless (tramp-equal-remote filename newname) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - (tramp-error - v 'file-error - "add-name-to-file: %s" - "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (when (and (not ok-if-already-exists) - (file-exists-p newname) - (not (numberp ok-if-already-exists)) - (y-or-n-p - (format - "File %s already exists; make it a new name anyway? " - newname))) - (tramp-error - v2 'file-error - "add-name-to-file: file %s already exists" newname)) - (tramp-flush-file-property v2 v2-localname) - (unless (tramp-fish-send-command-and-check - v1 (format "#LINK %s %s" v1-localname v2-localname)) - (tramp-error - v1 'file-error "Error with add-name-to-file %s" newname))))) - -(defun tramp-fish-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (tramp-fish-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) - -(defun tramp-fish-handle-delete-directory (directory &optional recursive) - "Like `delete-directory' for Tramp files." - (when (file-exists-p directory) - (if recursive - (mapc - (lambda (file) - (if (file-directory-p file) - (tramp-compat-delete-directory file recursive) - (delete-file file))) - ;; We do not want to delete "." and "..". - (directory-files - directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))) - (with-parsed-tramp-file-name - (directory-file-name (expand-file-name directory)) nil - (tramp-flush-directory-property v localname) - (tramp-fish-send-command-and-check v (format "#RMD %s" localname))))) - -(defun tramp-fish-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (when (file-exists-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-flush-file-property v localname) - (tramp-fish-send-command-and-check v (format "#DELE %s" localname))))) - -(defun tramp-fish-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (mapcar - (lambda (x) - (cons x - (tramp-compat-file-attributes - (if full x (expand-file-name x directory)) - id-format))) - (directory-files directory full match nosort))) - -(defun tramp-fish-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler, - (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) - (tramp-drop-volume-letter - (tramp-run-real-handler 'expand-file-name (list name nil))) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "~/" localname))) - ;; Tilde expansion if necessary. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot apply "~user/", because this is not supported - ;; by the FISH protocol. - (unless (string-equal uname "~") - (tramp-error - v 'file-error "Tilde expansion not supported for %s" name)) - (setq uname - (with-connection-property v uname - (tramp-fish-send-command-and-check v "#PWD") - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (tramp-compat-line-end-position))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; No tilde characters in file name, do normal - ;; expand-file-name (this does "/./" and "/../"). We bind - ;; `directory-sep-char' here for XEmacs on Windows, which - ;; would otherwise use backslash. `default-directory' is - ;; bound, because on Windows there would be problems with UNC - ;; shares or Cygwin mounts. - (let ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-fish-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname (format "file-attributes-%s" id-format) - (cdr (car (tramp-fish-get-file-entries v localname nil)))))) - -(defun tramp-fish-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (let ((attributes (file-attributes filename))) - (and attributes - (or (string-match "d" (nth 8 attributes)) - (and (file-symlink-p filename) - (with-parsed-tramp-file-name filename nil - (file-directory-p - (tramp-make-tramp-file-name - method user host (nth 0 attributes)))))) - t))) - -(defun tramp-fish-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (and (file-attributes filename) t)) - -(defun tramp-fish-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-executable-p" - (when (file-exists-p filename) - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 3) ?x) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 6) ?x) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 9) ?x))))))) - -(defun tramp-fish-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-readable-p" - (when (file-exists-p filename) - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 1) ?r) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 4) ?r) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 7) ?r))))))) - -(defun tramp-fish-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-writable-p" - (if (not (file-exists-p filename)) - ;; If file doesn't exist, check if directory is writable. - (and (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename))) - ;; Existing files must be writable. - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 2) ?w) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 5) ?w) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 8) ?w))))))) - -(defun tramp-fish-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (when (tramp-fish-retrieve-data v) - ;; Save file - (with-current-buffer (tramp-get-buffer v) - (write-region (point-min) (point-max) tmpfile)) - tmpfile))))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-fish-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-file-property v localname "file-name-all-completions" - (save-match-data - (let ((entries - (with-file-property v localname "file-entries" - (tramp-fish-get-file-entries v localname t)))) - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 9 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - entries))))))) - -(defun tramp-fish-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond - ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t (tramp-time-less-p (nth 5 (file-attributes file2)) - (nth 5 (file-attributes file1)))))) - -(defun tramp-fish-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files. -WILDCARD and FULL-DIRECTORY-P are not handled." - (setq filename (expand-file-name filename)) - (when (file-directory-p filename) - ;; This check is a little bit strange, but in `dired-add-entry' - ;; this function is called with a non-directory ... - (setq filename (file-name-as-directory filename))) - - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (save-match-data - (let ((entries - (with-file-property v localname "file-entries" - (tramp-fish-get-file-entries v localname t)))) - - ;; Sort entries - (setq entries - (sort - entries - (lambda (x y) - (if (string-match "t" switches) - ;; Sort by date. - (tramp-time-less-p (nth 6 y) (nth 6 x)) - ;; Sort by name. - (string-lessp (nth 0 x) (nth 0 y)))))) - - ;; Print entries. - (mapcar - (lambda (x) - (insert - (format - "%10s %3d %-8s %-8s %8s %s %s%s\n" - (nth 9 x) ; mode - 1 ; hardlinks - (nth 3 x) ; uid - (nth 4 x) ; gid - (nth 8 x) ; size - (format-time-string - (if (tramp-time-less-p - (tramp-time-subtract (current-time) (nth 6 x)) - tramp-half-a-year) - "%b %e %R" - "%b %e %Y") - (nth 6 x)) ; date - (nth 0 x) ; file name - (if (stringp (nth 1 x)) (format " -> %s" (nth 1 x)) ""))) - (forward-line) - (beginning-of-line)) - entries))))) - -(defun tramp-fish-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (when visit - (setq buffer-file-name (expand-file-name filename)) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - - (with-parsed-tramp-file-name filename nil - (if (not (file-exists-p filename)) - (tramp-error - v 'file-error "File %s not found on remote host" filename) - - (let ((point (point)) - size) - (with-progress-reporter v 3 (format "Fetching file %s" filename) - (when (tramp-fish-retrieve-data v) - ;; Insert file - (insert - (with-current-buffer (tramp-get-buffer v) - (let ((beg (or beg (point-min))) - (end (min (or end (point-max)) (point-max)))) - (setq size (- end beg)) - (buffer-substring beg end)))) - (goto-char point))) - - (list (expand-file-name filename) size))))) - -(defun tramp-fish-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (unless (file-name-absolute-p dir) - (setq dir (expand-file-name dir default-directory))) - (with-parsed-tramp-file-name dir nil - (save-match-data - (let ((ldir (file-name-directory dir))) - ;; Make missing directory parts - (when (and parents (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it - (when (file-directory-p ldir) - (make-directory-internal dir)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) - -(defun tramp-fish-handle-make-directory-internal (directory) - "Like `make-directory-internal' for Tramp files." - (setq directory (directory-file-name (expand-file-name directory))) - (unless (file-name-absolute-p directory) - (setq directory (expand-file-name directory default-directory))) - (when (file-directory-p (file-name-directory directory)) - (with-parsed-tramp-file-name directory nil - (save-match-data - (unless - (tramp-fish-send-command-and-check v (format "#MKD %s" localname)) - (tramp-error - v 'file-error "Couldn't make directory %s" directory)))))) - -(defun tramp-fish-handle-make-symbolic-link - (filename linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If LINKNAME is a non-Tramp file, it is used verbatim as the target of -the symlink. If LINKNAME is a Tramp file, only the localname component is -used as the target of the symlink. - -If LINKNAME is a Tramp file and the localname component is relative, then -it is expanded first, before the localname component is taken. Note that -this can give surprising results if the user/host for the source and -target of the symlink differ." - (with-parsed-tramp-file-name linkname nil - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - localname))))) - (tramp-error - v 'file-already-exists "File %s already exists" localname) - (delete-file linkname))) - - ;; If FILENAME is a Tramp name, use just the localname component. - (when (tramp-tramp-file-p filename) - (setq filename (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name filename))))) - - ;; Right, they are on the same host, regardless of user, method, etc. - ;; We now make the link on the remote machine. This will occur as the user - ;; that FILENAME belongs to. - (unless - (tramp-fish-send-command-and-check - v (format "#SYMLINK %s %s" filename localname)) - (tramp-error v 'file-error "Error creating symbolic link %s" linkname)))) - -(defun tramp-fish-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - (tramp-fish-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t)) - -(defun tramp-fish-handle-set-file-modes (filename mode) - "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (unless (tramp-fish-send-command-and-check - v (format "#CHMOD %s %s" - (tramp-decimal-to-octal mode) - (tramp-shell-quote-argument localname))) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) - -(defun tramp-fish-handle-set-file-times (filename &optional time) - "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) - (zerop (process-file - "touch" nil nil nil "-t" - (format-time-string "%Y%m%d%H%M.%S" time) - (tramp-shell-quote-argument localname)))))) - -(defun tramp-fish-handle-write-region - (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; XEmacs takes a coding system as the seventh argument, not `confirm' - (when (and (not (featurep 'xemacs)) - confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) - - (tramp-flush-file-property v localname) - - ;; Send command - (let ((tramp-fish-ok-prompt-regexp - (concat - tramp-fish-ok-prompt-regexp "\\|" - tramp-fish-continue-prompt-regexp))) - (tramp-fish-send-command - v (format "%s %d %s\n### 100" - (if append "#APPEND" "#STOR") (- end start) localname))) - - ;; Send data, if there are any. - (when (> end start) - (tramp-fish-send-command v (buffer-substring-no-properties start end))) - - (when (eq visit t) - (set-visited-file-modtime)))) - -(defun tramp-fish-handle-executable-find (command) - "Like `executable-find' for Tramp files." - (with-temp-buffer - (if (zerop (process-file "which" nil t nil command)) - (progn - (goto-char (point-min)) - (buffer-substring (point-min) (tramp-compat-line-end-position)))))) - -(defun tramp-fish-handle-process-file - (program &optional infile destination display &rest args) - "Like `process-file' for Tramp files." - ;; The implementation is not complete yet. - (when (and (numberp destination) (zerop destination)) - (error "Implementation does not handle immediate return")) - - (with-parsed-tramp-file-name default-directory nil - (let (command input tmpinput output tmpoutput stderr tmpstderr - outbuf tmpfile ret) - ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")) - ;; Determine input. - (if (null infile) - (setq input "/dev/null") - (setq infile (expand-file-name infile)) - (if (tramp-equal-remote default-directory infile) - ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) - ;; INFILE must be copied to remote host. - (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name method user host input)) - (copy-file infile tmpinput t))) - (when input (setq command (format "%s <%s" command input))) - - ;; Determine output. - (setq output (tramp-make-tramp-temp-file v) - tmpoutput (tramp-make-tramp-file-name method user host output)) - (cond - ;; Just a buffer - ((bufferp destination) - (setq outbuf destination)) - ;; A buffer name - ((stringp destination) - (setq outbuf (get-buffer-create destination))) - ;; (REAL-DESTINATION ERROR-DESTINATION) - ((consp destination) - ;; output - (cond - ((bufferp (car destination)) - (setq outbuf (car destination))) - ((stringp (car destination)) - (setq outbuf (get-buffer-create (car destination))))) - ;; stderr - (cond - ((stringp (cadr destination)) - (setcar (cdr destination) (expand-file-name (cadr destination))) - (if (tramp-equal-remote default-directory (cadr destination)) - ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) - ;; stderr must be copied to remote host. The temporary - ;; file must be deleted after execution. - (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user host stderr)))) - ;; stderr to be discarded - ((null (cadr destination)) - (setq stderr "/dev/null")))) - ;; 't - (destination - (setq outbuf (current-buffer)))) - (when stderr (setq command (format "%s 2>%s" command stderr))) - - ;; Goto working directory. - (unless - (tramp-fish-send-command-and-check - v (format "#CWD %s" (tramp-shell-quote-argument localname))) - (tramp-error v 'file-error "No such directory: %s" default-directory)) - ;; Send the command. It might not return in time, so we protect it. - (condition-case nil - (unwind-protect - (unless (tramp-fish-send-command-and-check - v (format - "#EXEC %s %s" - (tramp-shell-quote-argument command) output)) - (error nil)) - ;; Check return code. - (setq tmpfile - (file-local-copy - (tramp-make-tramp-file-name method user host output))) - (with-temp-buffer - (insert-file-contents tmpfile) - (goto-char (point-max)) - (forward-line -1) - (looking-at "^###RESULT: \\([0-9]+\\)") - (setq ret (string-to-number (match-string 1))) - (delete-region (point) (point-max)) - (write-region (point-min) (point-max) tmpfile)) - ;; We should show the output anyway. - (when outbuf - (with-current-buffer outbuf (insert-file-contents tmpfile)) - (when display (display-buffer outbuf)))) - ;; When the user did interrupt, we should do it also. - (error (setq ret 1))) - - ;; Provide error file. - (when tmpstderr (rename-file tmpstderr (cadr destination) t)) - ;; Cleanup. - (when tmpinput (delete-file tmpinput)) - (when tmpoutput (delete-file tmpoutput)) - ;; Return exit status. - ret))) - - -;; Internal file name functions - -(defun tramp-fish-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to -perform. FILENAME specifies the file to copy or rename, NEWNAME -is the name of the new file (for copy) or the new name of the -file (for rename). OK-IF-ALREADY-EXISTS means don't barf if -NEWNAME exists already. KEEP-DATE means to make sure that -NEWNAME has the same timestamp as FILENAME. - -This function is invoked by `tramp-fish-handle-copy-file' and -`tramp-fish-handle-rename-file'. It is an error if OP is neither -of `copy' and `rename'. FILENAME and NEWNAME must be absolute -file names." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname))) - - (unless ok-if-already-exists - (when (and t2 (file-exists-p newname)) - (with-parsed-tramp-file-name newname nil - (tramp-error - v 'file-already-exists "File %s already exists" newname)))) - - (prog1 - (cond - ;; Both are Tramp files. - ((and t1 t2) - (cond - ;; Shortcut: if method, host, user are the same for both - ;; files, we invoke `cp' or `mv' on the remote host - ;; directly. - ((tramp-equal-remote filename newname) - (tramp-fish-do-copy-or-rename-file-directly - op filename newname keep-date preserve-uid-gid)) - ;; No shortcut was possible. So we copy the - ;; file first. If the operation was `rename', we go - ;; back and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which filename handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) - ;; Use the generic method via a Tramp buffer. - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v localname) - (tramp-flush-file-property v (file-name-directory localname))))))) - -(defun tramp-fish-do-copy-or-rename-file-directly - (op filename newname keep-date preserve-uid-gid) - "Invokes `COPY' or `RENAME' on the remote system. -OP must be one of `copy' or `rename', indicating `cp' or `mv', -respectively. VEC specifies the connection. LOCALNAME1 and -LOCALNAME2 specify the two arguments of `cp' or `mv'. If -KEEP-DATE is non-nil, preserve the time stamp when copying. -PRESERVE-UID-GID is completely ignored." - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (tramp-fish-send-command - v1 - (format "%s %s %s" - (if (eq op 'copy) "#COPY" "#RENAME") - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname))))) - ;; KEEP-DATE handling. - (when (and keep-date (functionp 'set-file-times)) - (set-file-times newname (nth 5 (file-attributes filename)))) - ;; Set the mode. - (set-file-modes newname (tramp-default-file-modes filename))) - -(defun tramp-fish-get-file-entries (vec localname list) - "Read entries returned by FISH server. -When LIST is true, a #LIST command will be sent, including all entries -of a directory. Otherwise, #STAT is sent for just one entry. -Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD INODE DEVICE)." - (block nil - (with-current-buffer (tramp-get-buffer vec) - ;; #LIST does not work properly with trailing "/", at least in - ;; .fishsrv.pl. - (when (string-match "/$" localname) - (setq localname (concat localname "."))) - - (let ((command (format "%s %s" (if list "#LIST" "#STAT") localname)) - buffer-read-only num res) - - ;; Send command - (tramp-fish-send-command vec command) - - ;; Read number of entries - (goto-char (point-min)) - (condition-case nil - (unless (integerp (setq num (read (current-buffer)))) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Loop the listing - (dotimes (i num) - (let ((item (tramp-fish-read-file-entry))) - ;; Add inode and device. - (add-to-list - 'res (append item - (list (tramp-get-inode vec) - (tramp-get-device vec)))))) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) - (error (tramp-error - vec 'file-error - "`%s' does not return a valid Lisp expression: `%s'" - command (buffer-string)))) - (forward-line) - (delete-region (point-min) (point)) - - res)))) - -(defun tramp-fish-read-file-entry () - "Parse entry in output buffer. -Result is the list (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD)." - ;; We are called from `tramp-fish-get-file-entries', which sets the - ;; current buffer. - (let (buffer-read-only localname link uid gid mtime size mode) - (block nil - (while t - (cond - ;; P<unix permissions> <owner>.<group> - ((looking-at "^P\\(.+\\)\\s-\\(.+\\)\\.\\(.+\\)$") - (setq mode (match-string 1)) - (setq uid (match-string 2)) - (setq gid (match-string 3)) - (when (string-match "^d" mode) (setq link t))) - ;; S<size> - ((looking-at "^S\\([0-9]+\\)$") - (setq size (string-to-number (match-string 1)))) - ;; D<year> <month> <day> <hour> <minute> <second>[.1234] - ((looking-at - "^D\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\(\\S-+\\)$") - (setq mtime - (encode-time - (string-to-number (match-string 6)) - (string-to-number (match-string 5)) - (string-to-number (match-string 4)) - (string-to-number (match-string 3)) - (string-to-number (match-string 2)) - (string-to-number (match-string 1))))) - ;; d<3-letters month name> <day> <year or HH:MM> - ((looking-at "^d") nil) - ;; E<major-of-device>,<minor> - ((looking-at "^E") nil) - ;; :<filename> - ((looking-at "^:\\(.+\\)$") - (setq localname (match-string 1))) - ;; L<filename symlink points to> - ((looking-at "^L\\(.+\\)$") - (setq link (match-string 1))) - ;; M<mimetype> - ((looking-at "^M\\(.+\\)$") nil) - ;; last line - ((looking-at "^$") - (return))) - ;; Delete line. - (forward-line) - (delete-region (point-min) (point)))) - - ;; Delete trailing empty line. - (forward-line) - (delete-region (point-min) (point)) - - ;; Return entry in `file-attributes' format. - (list localname link -1 uid gid '(0 0) mtime '(0 0) size mode nil))) - -(defun tramp-fish-retrieve-data (vec) - "Reads remote data for FISH protocol. -The data are left in the connection buffer of VEC for further processing. -Returns the size of the data." - (block nil - (with-current-buffer (tramp-get-buffer vec) - ;; The retrieved data might be in binary format, without - ;; trailing newline. Therefore, the OK prompt might not start - ;; at the beginning of a line. - (let ((tramp-fish-ok-prompt-regexp "### 200\n") - size) - - ;; Send command - (tramp-fish-send-command - vec (format "#RETR %s" (tramp-file-name-localname vec))) - - ;; Read filesize - (goto-char (point-min)) - (condition-case nil - (unless (integerp (setq size (read (current-buffer)))) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; The received data might contain the OK prompt already, so - ;; there might be outstanding data. - (while (/= (+ size (length tramp-fish-ok-prompt-regexp)) - (- (point-max) (point-min))) - (tramp-wait-for-regexp - (tramp-get-connection-process vec) nil - (concat tramp-fish-ok-prompt-regexp "$"))) - - ;; Read return code - (goto-char (+ (point-min) size)) - (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) - (error (return nil))) - (delete-region (+ (point-min) size) (point-max)) - size)))) - - -;; Connection functions - -(defun tramp-fish-maybe-open-connection (vec) - "Maybe open a connection VEC. -Does not do anything if a connection is already open, but re-opens the -connection if a previous connection has died for some reason." - (let ((process-connection-type tramp-process-connection-type) - (p (get-buffer-process (tramp-get-buffer vec)))) - - ;; New connection must be opened. - (unless (and p (processp p) (memq (process-status p) '(run open))) - - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method vec) - tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - - ;; Start new process. - (when (and p (processp p)) - (delete-process p)) - (setenv "TERM" tramp-terminal-type) - (setenv "PS1" tramp-initial-end-of-output) - (with-progress-reporter - vec 3 - (format "Opening connection for %s@%s using %s" - tramp-current-user tramp-current-host tramp-current-method) - - (let* ((process-connection-type tramp-process-connection-type) - (inhibit-eol-conversion nil) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process - (or (tramp-get-connection-property vec "process-name" nil) - (tramp-buffer-name vec)) - (tramp-get-connection-buffer vec) - "ssh" "-l" - (tramp-file-name-user vec) - (tramp-file-name-host vec))))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - - ;; Check whether process is alive. - (tramp-set-process-query-on-exit-flag p nil) - - (tramp-process-actions p vec tramp-actions-before-shell 60) - (tramp-fish-send-command vec tramp-fish-start-fish-server-command) - (tramp-message - vec 3 - "Found remote shell prompt on `%s'" (tramp-file-name-host vec))))))) - -(defun tramp-fish-send-command (vec command) - "Send the COMMAND to connection VEC." - (tramp-fish-maybe-open-connection vec) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (tramp-wait-for-regexp - (tramp-get-connection-process vec) nil - (concat tramp-fish-ok-prompt-regexp "\\|" tramp-fish-error-prompt-regexp))) - -(defun tramp-fish-send-command-and-check (vec command) - "Send the COMMAND to connection VEC. -Returns nil if there has been an error message." - - ;; Send command. - (tramp-fish-send-command vec command) - - ;; Read return code. - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (looking-at tramp-fish-ok-prompt-regexp))) - -(provide 'tramp-fish) -; -;;;; TODO: -; -;; * Evaluate the MIME information with #LIST or #STAT. -; - -;; arch-tag: a66df7df-5f29-42a7-a921-643ceb29db49 -;;;; tramp-fish.el ends here
--- a/lisp/net/tramp-ftp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-ftp.el Wed Sep 22 15:46:51 2010 +0900 @@ -30,7 +30,6 @@ ;;; Code: (require 'tramp) -(autoload 'tramp-set-connection-property "tramp-cache") (eval-when-compile @@ -99,13 +98,14 @@ (add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp) ;; Define FTP method ... -(defcustom tramp-ftp-method "ftp" - "*When this method name is used, forward all calls to Ange-FTP." - :group 'tramp - :type 'string) +;;;###tramp-autoload +(defconst tramp-ftp-method "ftp" + "*When this method name is used, forward all calls to Ange-FTP.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-ftp-method nil)) +;;;###tramp-autoload +(unless (featurep 'xemacs) + (add-to-list 'tramp-methods (cons tramp-ftp-method nil))) ;; Add some defaults for `tramp-default-method-alist' (add-to-list 'tramp-default-method-alist @@ -129,6 +129,7 @@ (symbol-plist 'substitute-in-file-name)))))) +;;;###tramp-autoload (defun tramp-ftp-file-name-handler (operation &rest args) "Invoke the Ange-FTP handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -199,23 +200,26 @@ (inhibit-file-name-operation operation)) (apply 'ange-ftp-hook-function operation args))))))) -(defun tramp-ftp-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-ftp-file-name-p (filename) "Check if it's a filename that should be forwarded to Ange-FTP." (let ((v (tramp-dissect-file-name filename))) (string= (tramp-file-name-method v) tramp-ftp-method))) -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)) +;;;###tramp-autoload +(unless (featurep 'xemacs) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-ftp 'force))) (provide 'tramp-ftp) ;;; TODO: -;; * In case of "/ftp:host:file" this works only for functions which -;; are defined in `tramp-file-name-handler-alist'. Call has to be -;; pretended in `tramp-file-name-handler' otherwise. -;; Furthermore, there are no backup files on FTP hosts. -;; Worth further investigations. +;; * There are no backup files on FTP hosts. ;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff ;;; tramp-ftp.el ends here
--- a/lisp/net/tramp-gvfs.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-gvfs.el Wed Sep 22 15:46:51 2010 +0900 @@ -103,11 +103,17 @@ (require 'custom)) (require 'tramp) + +;; We call several `tramp-handle-*' functions directly. So we must +;; reqire that package as well. +(require 'tramp-sh) + (require 'dbus) (require 'url-parse) (require 'url-util) (require 'zeroconf) +;;;###tramp-autoload (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") "*List of methods for remote files, accessed with GVFS." :group 'tramp @@ -133,11 +139,11 @@ ;; Add the methods to `tramp-methods', in order to allow minibuffer ;; completion. -(eval-after-load "tramp-gvfs" - '(when (featurep 'tramp-gvfs) - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil)))))) +;;;###tramp-autoload +(when (featurep 'dbusbind) + (dolist (elt tramp-gvfs-methods) + (unless (assoc elt tramp-methods) + (add-to-list 'tramp-methods (cons elt nil))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceeding object path for own objects.") @@ -145,9 +151,12 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; Check that GVFS is available. -(unless (dbus-ping :session tramp-gvfs-service-daemon 100) - (throw 'tramp-loading nil)) +;; Check that GVFS is available. D-Bus integration is available since +;; Emacs 23 on some system types. We don't call `dbus-ping', because +;; this would load dbus.el. +(unless (and (tramp-compat-funcall 'dbus-get-unique-name :session) + (tramp-compat-process-running-p "gvfs-fuse-daemon")) + (error "Package `tramp-gvfs' not supported")) (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -385,7 +394,7 @@ (expand-file-name . tramp-gvfs-handle-expand-file-name) ;; `file-accessible-directory-p' performed by default handler. (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-gvfs-handle-file-directory-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-gvfs-handle-file-exists-p) (file-local-copy . tramp-gvfs-handle-file-local-copy) @@ -431,13 +440,15 @@ "Alist of handler functions for Tramp GVFS method. Operations not mentioned here will be handled by the default Emacs primitives.") -(defun tramp-gvfs-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-gvfs-file-name-p (filename) "Check if it's a filename handled by the GVFS daemon." (and (tramp-tramp-file-p filename) (let ((method (tramp-file-name-method (tramp-dissect-file-name filename)))) (and (stringp method) (member method tramp-gvfs-methods))))) +;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) "Invoke the GVFS related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -449,8 +460,10 @@ ;; This might be moved to tramp.el. It shall be the first file name ;; handler. -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) +;;;###tramp-autoload +(when (featurep 'dbusbind) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))) (defun tramp-gvfs-stringify-dbus-message (message) "Convert a D-Bus message into readable UTF8 strings, used for traces." @@ -485,7 +498,8 @@ (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defmacro with-tramp-gvfs-error-message (filename handler &rest args) "Apply a Tramp GVFS `handler'. @@ -494,7 +508,7 @@ `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) elt) (condition-case err - (funcall ,handler ,@args) + (tramp-compat-funcall ,handler ,@args) (error (setq elt (cdr err)) (while elt @@ -506,7 +520,8 @@ (put 'with-tramp-gvfs-error-message 'lisp-indent-function 2) (put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. @@ -647,6 +662,10 @@ "Like `file-attributes' for Tramp files." (file-attributes (tramp-gvfs-fuse-file-name filename) id-format)) +(defun tramp-gvfs-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (file-directory-p (tramp-gvfs-fuse-file-name filename))) + (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (file-executable-p (tramp-gvfs-fuse-file-name filename))) @@ -956,7 +975,7 @@ ;; host signature. (with-temp-buffer ;; Preserve message for `progress-reporter'. - (with-temp-message "" + (tramp-compat-with-temp-message "" (insert message) (pop-to-buffer (current-buffer)) (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) @@ -1403,6 +1422,10 @@ (tramp-set-completion-function "synce" '((tramp-synce-parse-device-names ""))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-gvfs 'force))) + (provide 'tramp-gvfs) ;;; TODO:
--- a/lisp/net/tramp-gw.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-gw.el Wed Sep 22 15:46:51 2010 +0900 @@ -38,11 +38,6 @@ (require 'cl) (require 'custom)) -;; Autoload the socks library. It is used only when we access a SOCKS server. -(autoload 'socks-open-network-stream "socks") -(defvar socks-username (user-login-name)) -(defvar socks-server (list "Default server" "socks" 1080 5)) - ;; Avoid byte-compiler warnings if the byte-compiler supports this. ;; Currently, XEmacs supports this. (eval-when-compile @@ -50,21 +45,29 @@ (byte-compiler-options (warnings (- unused-vars))))) ;; Define HTTP tunnel method ... -(defvar tramp-gw-tunnel-method "tunnel" +;;;###tramp-autoload +(defconst tramp-gw-tunnel-method "tunnel" "*Method to connect HTTP gateways.") ;; ... and port. -(defvar tramp-gw-default-tunnel-port 8080 +(defconst tramp-gw-default-tunnel-port 8080 "*Default port for HTTP gateways.") ;; Define SOCKS method ... -(defvar tramp-gw-socks-method "socks" +;;;###tramp-autoload +(defconst tramp-gw-socks-method "socks" "*Method to connect SOCKS servers.") ;; ... and port. -(defvar tramp-gw-default-socks-port 1080 +(defconst tramp-gw-default-socks-port 1080 "*Default port for SOCKS servers.") +;; Autoload the socks library. It is used only when we access a SOCKS server. +(autoload 'socks-open-network-stream "socks") +(defvar socks-username (user-login-name)) +(defvar socks-server + (list "Default server" "socks" tramp-gw-default-socks-port 5)) + ;; Add a default for `tramp-default-user-alist'. Default is the local user. (add-to-list 'tramp-default-user-alist `(,tramp-gw-tunnel-method nil ,(user-login-name))) @@ -125,6 +128,7 @@ (process-send-string (tramp-get-connection-property proc "process" nil) string))) +;;;###tramp-autoload (defun tramp-gw-open-connection (vec gw-vec target-vec) "Open a remote connection to VEC (see `tramp-file-name' structure). Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a @@ -239,10 +243,9 @@ ;; Trap errors to be traced in the right trace buffer. Often, ;; proxies have a timeout of 60". We wait 65" in order to ;; receive an answer this case. - (condition-case nil - (let (tramp-verbose) - (tramp-wait-for-regexp proc 65 "\r?\n\r?\n")) - (error nil)) + (ignore-errors + (let (tramp-verbose) + (tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))) ;; Check return code. (goto-char (point-min)) (narrow-to-region @@ -310,6 +313,9 @@ (format "Password for %s@[%s]: " socks-username (read (current-buffer))))))))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-gw 'force))) (provide 'tramp-gw)
--- a/lisp/net/tramp-imap.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-imap.el Wed Sep 22 15:46:51 2010 +0900 @@ -55,7 +55,6 @@ (require 'assoc) (require 'tramp) -(require 'tramp-compat) (autoload 'auth-source-user-or-password "auth-source") (autoload 'epg-context-operation "epg") @@ -76,21 +75,29 @@ '(add-to-list 'imap-hash-headers 'X-Size 'append)) ;; Define Tramp IMAP method ... +;;;###tramp-autoload (defconst tramp-imap-method "imap" "*Method to connect via IMAP protocol.") -(add-to-list 'tramp-methods (list tramp-imap-method '(tramp-default-port 143))) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-methods + (list tramp-imap-method '(tramp-default-port 143)))) ;; Add a default for `tramp-default-user-alist'. Default is the local user. (add-to-list 'tramp-default-user-alist `(,tramp-imap-method nil ,(user-login-name))) ;; Define Tramp IMAPS method ... +;;;###tramp-autoload (defconst tramp-imaps-method "imaps" "*Method to connect via secure IMAP protocol.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (list tramp-imaps-method '(tramp-default-port 993))) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-methods + (list tramp-imaps-method '(tramp-default-port 993)))) ;; Add a default for `tramp-default-user-alist'. Default is the local user. (add-to-list 'tramp-default-user-alist @@ -184,13 +191,15 @@ (defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never (defvar tramp-imap-passphrase nil) -(defun tramp-imap-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-imap-file-name-p (filename) "Check if it's a filename for IMAP protocol." (let ((v (tramp-dissect-file-name filename))) (or (string= (tramp-file-name-method v) tramp-imap-method) (string= (tramp-file-name-method v) tramp-imaps-method)))) +;;;###tramp-autoload (defun tramp-imap-file-name-handler (operation &rest args) "Invoke the IMAP related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -200,8 +209,10 @@ (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args)))) -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler)) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))) (defun tramp-imap-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -776,6 +787,10 @@ tramp-imap-subject-marker (if needed-subject needed-subject ""))))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-imap 'force))) + ;;; TODO: ;; * Implement `tramp-imap-handle-delete-directory',
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/tramp-sh.el Wed Sep 22 15:46:51 2010 +0900 @@ -0,0 +1,5509 @@ +;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; (copyright statements below in code to be updated with the above notice) + +;; Author: Kai Großjohann <kai.grossjohann@gmx.net> +;; Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(eval-when-compile (require 'cl)) ; ignore-errors +(require 'tramp) +(require 'shell) + +;; Pacify byte-compiler. The function is needed on XEmacs only. I'm +;; not sure at all that this is the right way to do it, but let's hope +;; it works for now, and wait for a guru to point out the Right Way to +;; achieve this. +;;(eval-when-compile +;; (unless (fboundp 'dired-insert-set-properties) +;; (fset 'dired-insert-set-properties 'ignore))) +;; Gerd suggests this: +(eval-when-compile (require 'dired)) +;; Note that dired is required at run-time, too, when it is needed. +;; It is only needed on XEmacs for the function +;; `dired-insert-set-properties'. + +(defcustom tramp-inline-compress-start-size 4096 + "*The minimum size of compressing where inline transfer. +When inline transfer, compress transfered data of file +whose size is this value or above (up to `tramp-copy-size-limit'). +If it is nil, no compression at all will be applied." + :group 'tramp + :type '(choice (const nil) integer)) + +(defcustom tramp-copy-size-limit 10240 + "*The maximum file size where inline copying is preferred over an out-of-the-band copy. +If it is nil, inline out-of-the-band copy will be used without a check." + :group 'tramp + :type '(choice (const nil) integer)) + +;;;###tramp-autoload +(defcustom tramp-terminal-type "dumb" + "*Value of TERM environment variable for logging in to remote host. +Because Tramp wants to parse the output of the remote shell, it is easily +confused by ANSI color escape sequences and suchlike. Often, shell init +files conditionalize this setup based on the TERM environment variable." + :group 'tramp + :type 'string) + +;; ksh on OpenBSD 4.5 requires, that PS1 contains a `#' character for +;; root users. It uses the `$' character for other users. In order +;; to guarantee a proper prompt, we use "#$" for the prompt. + +(defvar tramp-end-of-output + (format + "///%s#$" + (md5 (concat (prin1-to-string process-environment) (current-time-string)))) + "String used to recognize end of output. +The '$' character at the end is quoted; the string cannot be +detected as prompt when being sent on echoing hosts, therefore.") + +;;;###tramp-autoload +(defconst tramp-initial-end-of-output "#$ " + "Prompt when establishing a connection.") + +;; Initialize `tramp-methods' with the supported methods. +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rcp" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("remcp" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) +;;;###tramp-autoload +(add-to-list + 'tramp-methods + '("scp" (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scp1" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-1") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scp2" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-2") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scpc" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=yes") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=auto"))) + (tramp-copy-keep-date t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scpx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-e" "none") ("-t" "-t") + ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sftp" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "sftp"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rsync" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rsync") + (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + `("rsyncc" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=yes") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rsync") + (tramp-copy-args (("-t" "%k") ("-r"))) + (tramp-copy-env (("RSYNC_RSH") + (,(concat + "ssh" + " -o ControlPath=%t.%%r@%%h:%%p" + " -o ControlMaster=auto")))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rsh" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("remsh" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh1" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-1") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh2" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-2") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sshx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-e" "none") ("-t" "-t") + ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("telnet" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p"))) + (tramp-remote-sh "/bin/sh") + (tramp-default-port 23))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("su" + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sudo" + (tramp-login-program "sudo") + (tramp-login-args (("-u" "%u") ("-s") ("-H") ("-p" "Password:"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("krlogin" + (tramp-login-program "krlogin") + (tramp-login-args (("%h") ("-l" "%u") ("-x"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("plink" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("plink1" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-1" "-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + `("plinkx" + (tramp-login-program "plink") + ;; ("%h") must be a single element, see + ;; `tramp-compute-multi-hops'. + (tramp-login-args (("-load") ("%h") ("-t") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("pscp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "pscp") + (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k"))) + (tramp-copy-keep-date t) + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("psftp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "pscp") + (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k"))) + (tramp-copy-keep-date t) + (tramp-password-end-of-line "xy"))) ;see docstring for "xy" +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("fcp" + (tramp-login-program "fsh") + (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) + (tramp-remote-sh "/bin/sh -i") + (tramp-copy-program "fcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + +(add-to-list 'tramp-default-method-alist + `(,tramp-local-host-regexp "\\`root\\'" "su")) + +(add-to-list 'tramp-default-user-alist + '("\\`su\\(do\\)?\\'" nil "root")) +(add-to-list 'tramp-default-user-alist + `("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'" + nil ,(user-login-name))) + +(defconst tramp-completion-function-alist-rsh + '((tramp-parse-rhosts "/etc/hosts.equiv") + (tramp-parse-rhosts "~/.rhosts")) + "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.") + +(defconst tramp-completion-function-alist-ssh + '((tramp-parse-rhosts "/etc/hosts.equiv") + (tramp-parse-rhosts "/etc/shosts.equiv") + (tramp-parse-shosts "/etc/ssh_known_hosts") + (tramp-parse-sconfig "/etc/ssh_config") + (tramp-parse-shostkeys "/etc/ssh2/hostkeys") + (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") + (tramp-parse-rhosts "~/.rhosts") + (tramp-parse-rhosts "~/.shosts") + (tramp-parse-shosts "~/.ssh/known_hosts") + (tramp-parse-sconfig "~/.ssh/config") + (tramp-parse-shostkeys "~/.ssh2/hostkeys") + (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) + "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") + +(defconst tramp-completion-function-alist-telnet + '((tramp-parse-hosts "/etc/hosts")) + "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.") + +(defconst tramp-completion-function-alist-su + '((tramp-parse-passwd "/etc/passwd")) + "Default list of (FUNCTION FILE) pairs to be examined for su methods.") + +(defconst tramp-completion-function-alist-putty + '((tramp-parse-putty + "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions")) + "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.") + +(tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scp1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scp2" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scpc" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "sftp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsyncc" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh2" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh1_old" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh2_old" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet) +(tramp-set-completion-function "su" tramp-completion-function-alist-su) +(tramp-set-completion-function "sudo" tramp-completion-function-alist-su) +(tramp-set-completion-function "krlogin" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "plink1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty) +(tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh) + +;; "getconf PATH" yields: +;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin +;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin +;; GNU/Linux (Debian, Suse): /bin:/usr/bin +;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! +;; IRIX64: /usr/bin +(defcustom tramp-remote-path + '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin" + "/local/bin" "/local/freeware/bin" "/local/gnu/bin" + "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") + "*List of directories to search for executables on remote host. +For every remote host, this variable will be set buffer local, +keeping the list of existing directories on that host. + +You can use `~' in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with `~' will be ignored. + +`Default Directories' represent the list of directories given by +the command \"getconf PATH\". It is recommended to use this +entry on top of this list, because these are the default +directories for POSIX compatible commands. + +`Private Directories' are the settings of the $PATH environment, +as given in your `~/.profile'." + :group 'tramp + :type '(repeat (choice + (const :tag "Default Directories" tramp-default-remote-path) + (const :tag "Private Directories" tramp-own-remote-path) + (string :tag "Directory")))) + +(defcustom tramp-remote-process-environment + `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C" + ,(format "TERM=%s" tramp-terminal-type) + "EMACS=t" ;; Deprecated. + ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" + "autocorrect=" "correct=") + + "*List of environment variables to be set on the remote host. + +Each element should be a string of the form ENVVARNAME=VALUE. An +entry ENVVARNAME= diables the corresponding environment variable, +which might have been set in the init files like ~/.profile. + +Special handling is applied to the PATH environment, which should +not be set here. Instead of, it should be set via `tramp-remote-path'." + :group 'tramp + :type '(repeat string)) + +(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) + "*Alist specifying extra arguments to pass to the remote shell. +Entries are (REGEXP . ARGS) where REGEXP is a regular expression +matching the shell file name and ARGS is a string specifying the +arguments. + +This variable is only used when Tramp needs to start up another shell +for tilde expansion. The extra arguments should typically prevent the +shell from reading its init file." + :group 'tramp + ;; This might be the wrong way to test whether the widget type + ;; `alist' is available. Who knows the right way to test it? + :type (if (get 'alist 'widget-type) + '(alist :key-type string :value-type string) + '(repeat (cons string string)))) + +(defconst tramp-actions-before-shell + '((tramp-login-prompt-regexp tramp-action-login) + (tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (shell-prompt-pattern tramp-action-succeed) + (tramp-shell-prompt-pattern tramp-action-succeed) + (tramp-yesno-prompt-regexp tramp-action-yesno) + (tramp-yn-prompt-regexp tramp-action-yn) + (tramp-terminal-prompt-regexp tramp-action-terminal) + (tramp-process-alive-regexp tramp-action-process-alive)) + "List of pattern/action pairs. +Whenever a pattern matches, the corresponding action is performed. +Each item looks like (PATTERN ACTION). + +The PATTERN should be a symbol, a variable. The value of this +variable gives the regular expression to search for. Note that the +regexp must match at the end of the buffer, \"\\'\" is implicitly +appended to it. + +The ACTION should also be a symbol, but a function. When the +corresponding PATTERN matches, the ACTION function is called.") + +(defconst tramp-actions-copy-out-of-band + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-copy-failed-regexp tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-action-out-of-band)) + "List of pattern/action pairs. +This list is used for copying/renaming with out-of-band methods. + +See `tramp-actions-before-shell' for more info.") + +(defconst tramp-uudecode + "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode +cat /tmp/tramp.$$ +rm -f /tmp/tramp.$$" + "Shell function to implement `uudecode' to standard output. +Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' +for this or `uudecode -p', but some systems don't, and for them +we have this shell function.") + +(defconst tramp-perl-file-truename + "%s -e ' +use File::Spec; +use Cwd \"realpath\"; + +sub recursive { + my ($volume, @dirs) = @_; + my $real = realpath(File::Spec->catpath( + $volume, File::Spec->catdir(@dirs), \"\")); + if ($real) { + my ($vol, $dir) = File::Spec->splitpath($real, 1); + return ($vol, File::Spec->splitdir($dir)); + } + else { + my $last = pop(@dirs); + ($volume, @dirs) = recursive($volume, @dirs); + push(@dirs, $last); + return ($volume, @dirs); + } +} + +$result = realpath($ARGV[0]); +if (!$result) { + my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1); + ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir)); + + $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\"); +} + +if ($ARGV[0] =~ /\\/$/) { + $result = $result . \"/\"; +} + +print \"\\\"$result\\\"\\n\"; +' \"$1\" 2>/dev/null" + "Perl script to produce output suitable for use with `file-truename' +on the remote file system. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-file-name-all-completions + "%s -e 'sub case { + my $str = shift; + if ($ARGV[2]) { + return lc($str); + } + else { + return $str; + } +} +opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); +@files = readdir(d); closedir(d); +foreach $f (@files) { + if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) { + if (-d \"$ARGV[0]/$f\") { + print \"$f/\\n\"; + } + else { + print \"$f\\n\"; + } + } +} +print \"ok\\n\" +' \"$1\" \"$2\" \"$3\" 2>/dev/null" + "Perl script to produce output suitable for use with +`file-name-all-completions' on the remote file system. Escape +sequence %s is replaced with name of Perl binary. This string is +passed to `format', so percent characters need to be doubled.") + +;; Perl script to implement `file-attributes' in a Lisp `read'able +;; output. If you are hacking on this, note that you get *no* output +;; unless this spits out a complete line, including the '\n' at the +;; end. +;; The device number is returned as "-1", because there will be a virtual +;; device number set in `tramp-handle-file-attributes'. +(defconst tramp-perl-file-attributes + "%s -e ' +@stat = lstat($ARGV[0]); +if (!@stat) { + print \"nil\\n\"; + exit 0; +} +if (($stat[2] & 0170000) == 0120000) +{ + $type = readlink($ARGV[0]); + $type = \"\\\"$type\\\"\"; +} +elsif (($stat[2] & 0170000) == 040000) +{ + $type = \"t\"; +} +else +{ + $type = \"nil\" +}; +$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; +$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; +printf( + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", + $type, + $stat[3], + $uid, + $gid, + $stat[8] >> 16 & 0xffff, + $stat[8] & 0xffff, + $stat[9] >> 16 & 0xffff, + $stat[9] & 0xffff, + $stat[10] >> 16 & 0xffff, + $stat[10] & 0xffff, + $stat[7], + $stat[2], + $stat[1] >> 16 & 0xffff, + $stat[1] & 0xffff +);' \"$1\" \"$2\" 2>/dev/null" + "Perl script to produce output suitable for use with `file-attributes' +on the remote file system. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-directory-files-and-attributes + "%s -e ' +chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); +opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit(); +@list = readdir(DIR); +closedir(DIR); +$n = scalar(@list); +printf(\"(\\n\"); +for($i = 0; $i < $n; $i++) +{ + $filename = $list[$i]; + @stat = lstat($filename); + if (($stat[2] & 0170000) == 0120000) + { + $type = readlink($filename); + $type = \"\\\"$type\\\"\"; + } + elsif (($stat[2] & 0170000) == 040000) + { + $type = \"t\"; + } + else + { + $type = \"nil\" + }; + $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; + $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; + printf( + \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", + $filename, + $type, + $stat[3], + $uid, + $gid, + $stat[8] >> 16 & 0xffff, + $stat[8] & 0xffff, + $stat[9] >> 16 & 0xffff, + $stat[9] & 0xffff, + $stat[10] >> 16 & 0xffff, + $stat[10] & 0xffff, + $stat[7], + $stat[2], + $stat[1] >> 16 & 0xffff, + $stat[1] & 0xffff, + $stat[0] >> 16 & 0xffff, + $stat[0] & 0xffff); +} +printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null" + "Perl script implementing `directory-files-attributes' as Lisp `read'able +output. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +;; These two use base64 encoding. +(defconst tramp-perl-encode-with-module + "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null" + "Perl program to use for encoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled. +This implementation requires the MIME::Base64 Perl module to be installed +on the remote host.") + +(defconst tramp-perl-decode-with-module + "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null" + "Perl program to use for decoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled. +This implementation requires the MIME::Base64 Perl module to be installed +on the remote host.") + +(defconst tramp-perl-encode + "%s -e ' +# This script contributed by Juanma Barranquero <lektu@terra.es>. +# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +# Free Software Foundation, Inc. +use strict; + +my %%trans = do { + my $i = 0; + map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)} + split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/); +}; + +binmode(\\*STDIN); + +# We read in chunks of 54 bytes, to generate output lines +# of 72 chars (plus end of line) +$/ = \\54; + +while (my $data = <STDIN>) { + my $pad = q(); + + # Only for the last chunk, and only if did not fill the last three-byte packet + if (eof) { + my $mod = length($data) %% 3; + $pad = q(=) x (3 - $mod) if $mod; + } + + # Not the fastest method, but it is simple: unpack to binary string, split + # by groups of 6 bits and convert back from binary to byte; then map into + # the translation table + print + join q(), + map($trans{$_}, + (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)), + $pad, + qq(\\n); +}' 2>/dev/null" + "Perl program to use for encoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-decode + "%s -e ' +# This script contributed by Juanma Barranquero <lektu@terra.es>. +# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +# Free Software Foundation, Inc. +use strict; + +my %%trans = do { + my $i = 0; + map {($_, substr(unpack(q(B8), chr $i++), 2, 6))} + split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/) +}; + +my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255; + +binmode(\\*STDOUT); + +# We are going to accumulate into $pending to accept any line length +# (we do not check they are <= 76 chars as the RFC says) +my $pending = q(); + +while (my $data = <STDIN>) { + chomp $data; + + # If we find one or two =, we have reached the end and + # any following data is to be discarded + my $finished = $data =~ s/(==?).*/$1/; + $pending .= $data; + + my $len = length($pending); + my $chunk = substr($pending, 0, $len & ~3); + $pending = substr($pending, $len & ~3 + 1); + + # Easy method: translate from chars to (pregenerated) six-bit packets, join, + # split in 8-bit chunks and convert back to char. + print join q(), + map $bytes{$_}, + ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g); + + last if $finished; +}' 2>/dev/null" + "Perl program to use for decoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-vc-registered-read-file-names + "echo \"(\" +while read file; do + if %s \"$file\"; then + echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" + else + echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" + fi + if %s \"$file\"; then + echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" + else + echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" + fi +done +echo \")\"" + "Script to check existence of VC related files. +It must be send formatted with two strings; the tests for file +existence, and file readability. Input shall be read via +here-document, otherwise the command could exceed maximum length +of command line.") + +(defconst tramp-file-mode-type-map + '((0 . "-") ; Normal file (SVID-v2 and XPG2) + (1 . "p") ; fifo + (2 . "c") ; character device + (3 . "m") ; multiplexed character device (v7) + (4 . "d") ; directory + (5 . "?") ; Named special file (XENIX) + (6 . "b") ; block device + (7 . "?") ; multiplexed block device (v7) + (8 . "-") ; regular file + (9 . "n") ; network special file (HP-UX) + (10 . "l") ; symlink + (11 . "?") ; ACL shadow inode (Solaris, not userspace) + (12 . "s") ; socket + (13 . "D") ; door special (Solaris) + (14 . "w")) ; whiteout (BSD) + "A list of file types returned from the `stat' system call. +This is used to map a mode number to a permission string.") + +;; New handlers should be added here. The following operations can be +;; handled using the normal primitives: file-name-sans-versions, +;; get-file-buffer. +(defconst tramp-sh-file-name-handler-alist + '((load . tramp-handle-load) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + (file-truename . tramp-handle-file-truename) + (file-exists-p . tramp-handle-file-exists-p) + (file-directory-p . tramp-handle-file-directory-p) + (file-executable-p . tramp-handle-file-executable-p) + (file-readable-p . tramp-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-writable-p . tramp-handle-file-writable-p) + (file-ownership-preserved-p . tramp-handle-file-ownership-preserved-p) + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-attributes . tramp-handle-file-attributes) + (file-modes . tramp-handle-file-modes) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) + (file-name-all-completions . tramp-handle-file-name-all-completions) + (file-name-completion . tramp-handle-file-name-completion) + (add-name-to-file . tramp-handle-add-name-to-file) + (copy-file . tramp-handle-copy-file) + (copy-directory . tramp-handle-copy-directory) + (rename-file . tramp-handle-rename-file) + (set-file-modes . tramp-handle-set-file-modes) + (set-file-times . tramp-handle-set-file-times) + (make-directory . tramp-handle-make-directory) + (delete-directory . tramp-handle-delete-directory) + (delete-file . tramp-handle-delete-file) + (directory-file-name . tramp-handle-directory-file-name) + ;; `executable-find' is not official yet. + (executable-find . tramp-handle-executable-find) + (start-file-process . tramp-handle-start-file-process) + (process-file . tramp-handle-process-file) + (shell-command . tramp-handle-shell-command) + (insert-directory . tramp-handle-insert-directory) + (expand-file-name . tramp-handle-expand-file-name) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (file-local-copy . tramp-handle-file-local-copy) + (file-remote-p . tramp-handle-file-remote-p) + (insert-file-contents . tramp-handle-insert-file-contents) + (insert-file-contents-literally + . tramp-handle-insert-file-contents-literally) + (write-region . tramp-handle-write-region) + (find-backup-file-name . tramp-handle-find-backup-file-name) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (dired-compress-file . tramp-handle-dired-compress-file) + (dired-recursive-delete-directory + . tramp-handle-dired-recursive-delete-directory) + (dired-uncache . tramp-handle-dired-uncache) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (file-selinux-context . tramp-handle-file-selinux-context) + (set-file-selinux-context . tramp-handle-set-file-selinux-context) + (vc-registered . tramp-handle-vc-registered)) + "Alist of handler functions. +Operations not mentioned here will be handled by the normal Emacs functions.") + +;; This must be the last entry, because `identity' always matches. +;;;###tramp-autoload +(add-to-list 'tramp-foreign-file-name-handler-alist + '(identity . tramp-sh-file-name-handler) 'append) + +;;; File Name Handler Functions: + +(defun tramp-handle-make-symbolic-link + (filename linkname &optional ok-if-already-exists) + "Like `make-symbolic-link' for Tramp files. +If LINKNAME is a non-Tramp file, it is used verbatim as the target of +the symlink. If LINKNAME is a Tramp file, only the localname component is +used as the target of the symlink. + +If LINKNAME is a Tramp file and the localname component is relative, then +it is expanded first, before the localname component is taken. Note that +this can give surprising results if the user/host for the source and +target of the symlink differ." + (with-parsed-tramp-file-name linkname l + (let ((ln (tramp-get-remote-ln l)) + (cwd (tramp-run-real-handler + 'file-name-directory (list l-localname)))) + (unless ln + (tramp-error + l 'file-error + "Making a symbolic link. ln(1) does not exist on the remote host.")) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + l-localname))))) + (tramp-error + l 'file-already-exists "File %s already exists" l-localname) + (delete-file linkname))) + + ;; If FILENAME is a Tramp name, use just the localname component. + (when (tramp-tramp-file-p filename) + (setq filename + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name filename))))) + + (tramp-flush-file-property l (file-name-directory l-localname)) + (tramp-flush-file-property l l-localname) + + ;; Right, they are on the same host, regardless of user, method, etc. + ;; We now make the link on the remote machine. This will occur as the user + ;; that FILENAME belongs to. + (tramp-send-command-and-check + l + (format + "cd %s && %s -sf %s %s" + (tramp-shell-quote-argument cwd) + ln + (tramp-shell-quote-argument filename) + (tramp-shell-quote-argument l-localname)) + t)))) + +(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name file) nil + (unless nosuffix + (cond ((file-exists-p (concat file ".elc")) + (setq file (concat file ".elc"))) + ((file-exists-p (concat file ".el")) + (setq file (concat file ".el"))))) + (when must-suffix + ;; The first condition is always true for absolute file names. + ;; Included for safety's sake. + (unless (or (file-name-directory file) + (string-match "\\.elc?\\'" file)) + (tramp-error + v 'file-error + "File `%s' does not include a `.el' or `.elc' suffix" file))) + (unless noerror + (when (not (file-exists-p file)) + (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file))) + (if (not (file-exists-p file)) + nil + (let ((tramp-message-show-message (not nomessage))) + (with-progress-reporter v 0 (format "Loading %s" file) + (let ((local-copy (file-local-copy file))) + ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. + (unwind-protect + (load local-copy noerror t t) + (delete-file local-copy))))) + t))) + +;; Localname manipulation functions that grok Tramp localnames... +(defun tramp-handle-file-name-as-directory (file) + "Like `file-name-as-directory' but aware of Tramp files." + ;; `file-name-as-directory' would be sufficient except localname is + ;; the empty string. + (let ((v (tramp-dissect-file-name file t))) + ;; Run the command on the localname portion only. + (tramp-make-tramp-file-name + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (tramp-run-real-handler + 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))))) + +(defun tramp-handle-file-name-directory (file) + "Like `file-name-directory' but aware of Tramp files." + ;; Everything except the last filename thing is the directory. We + ;; cannot apply `with-parsed-tramp-file-name', because this expands + ;; the remote file name parts. This is a problem when we are in + ;; file name completion. + (let ((v (tramp-dissect-file-name file t))) + ;; Run the command on the localname portion only. + (tramp-make-tramp-file-name + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) + +(defun tramp-handle-file-name-nondirectory (file) + "Like `file-name-nondirectory' but aware of Tramp files." + (with-parsed-tramp-file-name file nil + (tramp-run-real-handler 'file-name-nondirectory (list localname)))) + +(defun tramp-handle-file-truename (filename &optional counter prev-dirs) + "Like `file-truename' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-file-property v localname "file-truename" + (let ((result nil)) ; result steps in reverse order + (tramp-message v 4 "Finding true name for `%s'" filename) + (cond + ;; Use GNU readlink --canonicalize-missing where available. + ((tramp-get-remote-readlink v) + (setq result + (tramp-send-command-and-read + v + (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\"" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec" nil) + (tramp-get-connection-property v "perl-cwd-realpath" nil)) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (setq result + (tramp-send-command-and-read + v + (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname))))) + + ;; Do it yourself. We bind `directory-sep-char' here for + ;; XEmacs on Windows, which would otherwise use backslash. + (t (let* ((directory-sep-char ?/) + (steps (tramp-compat-split-string localname "/")) + (localnamedir (tramp-run-real-handler + 'file-name-as-directory (list localname))) + (is-dir (string= localname localnamedir)) + (thisstep nil) + (numchase 0) + ;; Don't make the following value larger than + ;; necessary. People expect an error message in a + ;; timely fashion when something is wrong; + ;; otherwise they might think that Emacs is hung. + ;; Of course, correctness has to come first. + (numchase-limit 20) + symlink-target) + (while (and steps (< numchase numchase-limit)) + (setq thisstep (pop steps)) + (tramp-message + v 5 "Check %s" + (mapconcat 'identity + (append '("") (reverse result) (list thisstep)) + "/")) + (setq symlink-target + (nth 0 (file-attributes + (tramp-make-tramp-file-name + method user host + (mapconcat 'identity + (append '("") + (reverse result) + (list thisstep)) + "/"))))) + (cond ((string= "." thisstep) + (tramp-message v 5 "Ignoring step `.'")) + ((string= ".." thisstep) + (tramp-message v 5 "Processing step `..'") + (pop result)) + ((stringp symlink-target) + ;; It's a symlink, follow it. + (tramp-message v 5 "Follow symlink to %s" symlink-target) + (setq numchase (1+ numchase)) + (when (file-name-absolute-p symlink-target) + (setq result nil)) + ;; If the symlink was absolute, we'll get a string like + ;; "/user@host:/some/target"; extract the + ;; "/some/target" part from it. + (when (tramp-tramp-file-p symlink-target) + (unless (tramp-equal-remote filename symlink-target) + (tramp-error + v 'file-error + "Symlink target `%s' on wrong host" symlink-target)) + (setq symlink-target localname)) + (setq steps + (append (tramp-compat-split-string + symlink-target "/") + steps))) + (t + ;; It's a file. + (setq result (cons thisstep result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit)) + (setq result (reverse result)) + ;; Combine list to form string. + (setq result + (if result + (mapconcat 'identity (cons "" result) "/") + "/")) + (when (and is-dir (or (string= "" result) + (not (string= (substring result -1) "/")))) + (setq result (concat result "/")))))) + + (tramp-message v 4 "True name of `%s' is `%s'" filename result) + (tramp-make-tramp-file-name method user host result))))) + +;; Basic functions. + +(defun tramp-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-exists-p" + (or (not (null (tramp-get-file-property + v localname "file-attributes-integer" nil))) + (not (null (tramp-get-file-property + v localname "file-attributes-string" nil))) + (tramp-send-command-and-check + v + (format + "%s %s" + (tramp-get-file-exists-command v) + (tramp-shell-quote-argument localname))))))) + +;; CCC: This should check for an error condition and signal failure +;; when something goes wrong. +;; Daniel Pittman <daniel@danann.net> +(defun tramp-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-file-property v localname (format "file-attributes-%s" id-format) + (save-excursion + (tramp-convert-file-attributes + v + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t + (tramp-do-file-attributes-with-ls v localname id-format))))))))) + +(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using the ls(1) command." + (let (symlinkp dirp + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) + (tramp-message vec 5 "file attributes with ls: %s" localname) + (tramp-send-command + vec + (format "(%s %s || %s -h %s) && %s %s %s" + (tramp-get-file-exists-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-test-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-ls-command vec) + (if (eq id-format 'integer) "-ildn" "-ild") + (tramp-shell-quote-argument localname))) + ;; parse `ls -l' output ... + (with-current-buffer (tramp-get-buffer vec) + (when (> (buffer-size) 0) + (goto-char (point-min)) + ;; ... inode + (setq res-inode + (condition-case err + (read (current-buffer)) + (invalid-read-syntax + (when (and (equal (cadr err) + "Integer constant overflow in reader") + (string-match + "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'" + (car (cddr err)))) + (let* ((big (read (substring (car (cddr err)) 0 + (match-beginning 1)))) + (small (read (match-string 1 (car (cddr err))))) + (twiddle (/ small 65536))) + (cons (+ big twiddle) + (- small (* twiddle 65536)))))))) + ;; ... file mode flags + (setq res-filemodes (symbol-name (read (current-buffer)))) + ;; ... number links + (setq res-numlinks (read (current-buffer))) + ;; ... uid and gid + (setq res-uid (read (current-buffer))) + (setq res-gid (read (current-buffer))) + (if (eq id-format 'integer) + (progn + (unless (numberp res-uid) (setq res-uid -1)) + (unless (numberp res-gid) (setq res-gid -1))) + (progn + (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) + (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) + ;; ... size + (setq res-size (read (current-buffer))) + ;; From the file modes, figure out other stuff. + (setq symlinkp (eq ?l (aref res-filemodes 0))) + (setq dirp (eq ?d (aref res-filemodes 0))) + ;; if symlink, find out file name pointed to + (when symlinkp + (search-forward "-> ") + (setq res-symlink-target + (buffer-substring (point) (tramp-compat-line-end-position)))) + ;; return data gathered + (list + ;; 0. t for directory, string (name linked to) for symbolic + ;; link, or nil. + (or dirp res-symlink-target) + ;; 1. Number of links to file. + res-numlinks + ;; 2. File uid. + res-uid + ;; 3. File gid. + res-gid + ;; 4. Last access time, as a list of two integers. First + ;; integer has high-order 16 bits of time, second has low 16 + ;; bits. + ;; 5. Last modification time, likewise. + ;; 6. Last status change time, likewise. + '(0 0) '(0 0) '(0 0) ;CCC how to find out? + ;; 7. Size in bytes (-1, if number is out of range). + res-size + ;; 8. File modes, as a string of ten letters or dashes as in ls -l. + res-filemodes + ;; 9. t if file's gid would change if file were deleted and + ;; recreated. Will be set in `tramp-convert-file-attributes' + t + ;; 10. inode number. + res-inode + ;; 11. Device number. Will be replaced by a virtual device number. + -1 + ))))) + +(defun tramp-do-file-attributes-with-perl + (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using a Perl script." + (tramp-message vec 5 "file attributes with perl: %s" localname) + (tramp-maybe-send-script + vec tramp-perl-file-attributes "tramp_perl_file_attributes") + (tramp-send-command-and-read + vec + (format "tramp_perl_file_attributes %s %s" + (tramp-shell-quote-argument localname) id-format))) + +(defun tramp-do-file-attributes-with-stat + (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using stat(1) command." + (tramp-message vec 5 "file attributes with stat: %s" localname) + (tramp-send-command-and-read + vec + (format + ;; On Opsware, pdksh (which is the true name of ksh there) doesn't + ;; parse correctly the sequence "((". Therefore, we add a space. + "( (%s %s || %s -h %s) && %s -c '( (\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s.0 \"%%A\" t %%i.0 -1)' %s || echo nil)" + (tramp-get-file-exists-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-test-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-remote-stat vec) + (if (eq id-format 'integer) "%u" "\"%U\"") + (if (eq id-format 'integer) "%g" "\"%G\"") + (tramp-shell-quote-argument localname)))) + +(defun tramp-handle-set-visited-file-modtime (&optional time-list) + "Like `set-visited-file-modtime' for Tramp files." + (unless (buffer-file-name) + (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" + (buffer-name))) + (if time-list + (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) + (let ((f (buffer-file-name)) + coding-system-used) + (with-parsed-tramp-file-name f nil + (let* ((attr (file-attributes f)) + ;; '(-1 65535) means file doesn't exists yet. + (modtime (or (nth 5 attr) '(-1 65535)))) + (when (boundp 'last-coding-system-used) + (setq coding-system-used (symbol-value 'last-coding-system-used))) + ;; We use '(0 0) as a don't-know value. See also + ;; `tramp-do-file-attributes-with-ls'. + (if (not (equal modtime '(0 0))) + (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) + (progn + (tramp-send-command + v + (format "%s -ild %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname))) + (setq attr (buffer-substring (point) + (progn (end-of-line) (point))))) + (tramp-set-file-property + v localname "visited-file-modtime-ild" attr)) + (when (boundp 'last-coding-system-used) + (set 'last-coding-system-used coding-system-used)) + nil))))) + +;; This function makes the same assumption as +;; `tramp-handle-set-visited-file-modtime'. +(defun tramp-handle-verify-visited-file-modtime (buf) + "Like `verify-visited-file-modtime' for Tramp files. +At the time `verify-visited-file-modtime' calls this function, we +already know that the buffer is visiting a file and that +`visited-file-modtime' does not return 0. Do not call this +function directly, unless those two cases are already taken care +of." + (with-current-buffer buf + (let ((f (buffer-file-name))) + ;; There is no file visiting the buffer, or the buffer has no + ;; recorded last modification time, or there is no established + ;; connection. + (if (or (not f) + (eq (visited-file-modtime) 0) + (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) + t + (with-parsed-tramp-file-name f nil + (tramp-flush-file-property v localname) + (let* ((attr (file-attributes f)) + (modtime (nth 5 attr)) + (mt (visited-file-modtime))) + + (cond + ;; File exists, and has a known modtime. + ((and attr (not (equal modtime '(0 0)))) + (< (abs (tramp-time-diff + modtime + ;; For compatibility, deal with both the old + ;; (HIGH . LOW) and the new (HIGH LOW) return + ;; values of `visited-file-modtime'. + (if (atom (cdr mt)) + (list (car mt) (cdr mt)) + mt))) + 2)) + ;; Modtime has the don't know value. + (attr + (tramp-send-command + v + (format "%s -ild %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-buffer v) + (setq attr (buffer-substring + (point) (progn (end-of-line) (point))))) + (equal + attr + (tramp-get-file-property + v localname "visited-file-modtime-ild" ""))) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (equal mt '(-1 65535)))))))))) + +(defun tramp-handle-set-file-modes (filename mode) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v localname) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format "chmod %s %s" + (tramp-compat-decimal-to-octal mode) + (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename))) + +(defun tramp-handle-set-file-times (filename &optional time) + "Like `set-file-times' for Tramp files." + (if (file-remote-p filename) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v localname) + (let ((time (if (or (null time) (equal time '(0 0))) + (current-time) + time)) + ;; With GNU Emacs, `format-time-string' has an optional + ;; parameter UNIVERSAL. This is preferred, because we + ;; could handle the case when the remote host is located + ;; in a different time zone as the local host. + (utc (not (featurep 'xemacs)))) + (tramp-send-command-and-check + v (format "%s touch -t %s %s" + (if utc "TZ=UTC; export TZ;" "") + (if utc + (format-time-string "%Y%m%d%H%M.%S" time t) + (format-time-string "%Y%m%d%H%M.%S" time)) + (tramp-shell-quote-argument localname))))) + + ;; We handle also the local part, because in older Emacsen, + ;; without `set-file-times', this function is an alias for this. + ;; We are local, so we don't need the UTC settings. + (zerop + (tramp-compat-call-process + "touch" nil nil nil "-t" + (format-time-string "%Y%m%d%H%M.%S" time) + (tramp-shell-quote-argument filename))))) + +(defun tramp-set-file-uid-gid (filename &optional uid gid) + "Set the ownership for FILENAME. +If UID and GID are provided, these values are used; otherwise uid +and gid of the corresponding user is taken. Both parameters must be integers." + ;; Modern Unices allow chown only for root. So we might need + ;; another implementation, see `dired-do-chown'. OTOH, it is mostly + ;; working with su(do)? when it is needed, so it shall succeed in + ;; the majority of cases. + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (if (file-remote-p filename) + (with-parsed-tramp-file-name filename nil + (if (and (zerop (user-uid)) (tramp-local-host-p v)) + ;; If we are root on the local host, we can do it directly. + (tramp-set-file-uid-gid localname uid gid) + (let ((uid (or (and (integerp uid) uid) + (tramp-get-remote-uid v 'integer))) + (gid (or (and (integerp gid) gid) + (tramp-get-remote-gid v 'integer)))) + (tramp-send-command + v (format + "chown %d:%d %s" uid gid + (tramp-shell-quote-argument localname)))))) + + ;; We handle also the local part, because there doesn't exist + ;; `set-file-uid-gid'. On W32 "chown" might not work. + (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-compat-call-process + "chown" nil nil nil + (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)))))) + +(defun tramp-remote-selinux-p (vec) + "Check, whether SELINUX is enabled on the remote host." + (with-connection-property (tramp-get-connection-process vec) "selinux-p" + (let ((result (tramp-find-executable + vec "getenforce" (tramp-get-remote-path vec) t t))) + (and result + (string-equal + (tramp-send-command-and-read + vec (format "echo \\\"`%S`\\\"" result)) + "Enforcing"))))) + +(defun tramp-handle-file-selinux-context (filename) + "Like `file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-selinux-context" + (let ((context '(nil nil nil nil)) + (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) + (when (and (tramp-remote-selinux-p v) + (tramp-send-command-and-check + v (format + "%s -d -Z %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname)))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (when (re-search-forward regexp (tramp-compat-line-end-position) t) + (setq context (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4)))))) + ;; Return the context. + context)))) + +(defun tramp-handle-set-file-selinux-context (filename context) + "Like `set-file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (if (and (consp context) + (tramp-remote-selinux-p v) + (tramp-send-command-and-check + v (format "chcon %s %s %s %s %s" + (if (stringp (nth 0 context)) + (format "--user=%s" (nth 0 context)) "") + (if (stringp (nth 1 context)) + (format "--role=%s" (nth 1 context)) "") + (if (stringp (nth 2 context)) + (format "--type=%s" (nth 2 context)) "") + (if (stringp (nth 3 context)) + (format "--range=%s" (nth 3 context)) "") + (tramp-shell-quote-argument localname)))) + (tramp-set-file-property v localname "file-selinux-context" context) + (tramp-set-file-property v localname "file-selinux-context" 'undef))) + ;; We always return nil. + nil) + +;; Simple functions using the `test' command. + +(defun tramp-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-executable-p" + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?x) + (tramp-run-test "-x" filename))))) + +(defun tramp-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-readable-p" + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?r) + (tramp-run-test "-r" filename))))) + +;; When the remote shell is started, it looks for a shell which groks +;; tilde expansion. Here, we assume that all shells which grok tilde +;; expansion will also provide a `test' command which groks `-nt' (for +;; newer than). If this breaks, tell me about it and I'll try to do +;; something smarter about it. +(defun tramp-handle-file-newer-than-file-p (file1 file2) + "Like `file-newer-than-file-p' for Tramp files." + (cond ((not (file-exists-p file1)) + nil) + ((not (file-exists-p file2)) + t) + ;; We are sure both files exist at this point. + (t + (save-excursion + ;; We try to get the mtime of both files. If they are not + ;; equal to the "dont-know" value, then we subtract the times + ;; and obtain the result. + (let ((fa1 (file-attributes file1)) + (fa2 (file-attributes file2))) + (if (and (not (equal (nth 5 fa1) '(0 0))) + (not (equal (nth 5 fa2) '(0 0)))) + (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1))) + ;; If one of them is the dont-know value, then we can + ;; still try to run a shell command on the remote host. + ;; However, this only works if both files are Tramp + ;; files and both have the same method, same user, same + ;; host. + (unless (tramp-equal-remote file1 file2) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p file1) file1 file2) nil + (tramp-error + v 'file-error + "Files %s and %s must have same method, user, host" + file1 file2))) + (with-parsed-tramp-file-name file1 nil + (tramp-run-test2 + (tramp-get-test-nt-command v) file1 file2)))))))) + +;; Functions implemented using the basic functions above. + +(defun tramp-handle-file-modes (filename) + "Like `file-modes' for Tramp files." + (let ((truename (or (file-truename filename) filename))) + (when (file-exists-p truename) + (tramp-mode-string-to-int (nth 8 (file-attributes truename)))))) + +(defun tramp-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + ;; Care must be taken that this function returns `t' for symlinks + ;; pointing to directories. Surely the most obvious implementation + ;; would be `test -d', but that returns false for such symlinks. + ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And + ;; I now think he's right. So we could be using `test -d', couldn't + ;; we? + ;; + ;; Alternatives: `cd %s', `test -d %s' + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-directory-p" + (tramp-run-test "-d" filename)))) + +(defun tramp-handle-file-regular-p (filename) + "Like `file-regular-p' for Tramp files." + (and (file-exists-p filename) + (eq ?- (aref (nth 8 (file-attributes filename)) 0)))) + +(defun tramp-handle-file-symlink-p (filename) + "Like `file-symlink-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (let ((x (car (file-attributes filename)))) + (when (stringp x) + ;; When Tramp is running on VMS, then `file-name-absolute-p' + ;; might do weird things. + (if (file-name-absolute-p x) + (tramp-make-tramp-file-name method user host x) + x))))) + +(defun tramp-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-writable-p" + (if (file-exists-p filename) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?w) + (tramp-run-test "-w" filename)) + ;; If file doesn't exist, check if directory is writable. + (and (tramp-run-test "-d" (file-name-directory filename)) + (tramp-run-test "-w" (file-name-directory filename))))))) + +(defun tramp-handle-file-ownership-preserved-p (filename) + "Like `file-ownership-preserved-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-ownership-preserved-p" + (let ((attributes (file-attributes filename))) + ;; Return t if the file doesn't exist, since it's true that no + ;; information would be lost by an (attempted) delete and create. + (or (null attributes) + (= (nth 2 attributes) (tramp-get-remote-uid v 'integer))))))) + +;; Other file name ops. + +(defun tramp-handle-directory-file-name (directory) + "Like `directory-file-name' for Tramp files." + ;; If localname component of filename is "/", leave it unchanged. + ;; Otherwise, remove any trailing slash from localname component. + ;; Method, host, etc, are unchanged. Does it make sense to try + ;; to avoid parsing the filename? + (with-parsed-tramp-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + directory))) + +;; Directory listings. + +(defun tramp-handle-directory-files + (directory &optional full match nosort files-only) + "Like `directory-files' for Tramp files." + ;; FILES-ONLY is valid for XEmacs only. + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let ((temp (nreverse (file-name-all-completions "" directory))) + result item) + + (while temp + (setq item (directory-file-name (pop temp))) + (when (and (or (null match) (string-match match item)) + (or (null files-only) + ;; Files only. + (and (equal files-only t) (file-regular-p item)) + ;; Directories only. + (file-directory-p item))) + (push (if full (concat directory item) item) + result))) + (if nosort result (sort result 'string<))))) + +(defun tramp-handle-directory-files-and-attributes + (directory &optional full match nosort id-format) + "Like `directory-files-and-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + (when (file-directory-p directory) + (setq directory (expand-file-name directory)) + (let* ((temp + (copy-tree + (with-parsed-tramp-file-name directory nil + (with-file-property + v localname + (format "directory-files-and-attributes-%s" id-format) + (save-excursion + (mapcar + (lambda (x) + (cons (car x) + (tramp-convert-file-attributes v (cdr x)))) + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format))))))))) + result item) + + (while temp + (setq item (pop temp)) + (when (or (null match) (string-match match (car item))) + (when full + (setcar item (expand-file-name (car item) directory))) + (push item result))) + + (if nosort + result + (sort result (lambda (x y) (string< (car x) (car y)))))))) + +(defun tramp-do-directory-files-and-attributes-with-perl + (vec localname &optional id-format) + "Implement `directory-files-and-attributes' for Tramp files using a Perl script." + (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) + (tramp-maybe-send-script + vec tramp-perl-directory-files-and-attributes + "tramp_perl_directory_files_and_attributes") + (let ((object + (tramp-send-command-and-read + vec + (format "tramp_perl_directory_files_and_attributes %s %s" + (tramp-shell-quote-argument localname) id-format)))) + (when (stringp object) (tramp-error vec 'file-error object)) + object)) + +(defun tramp-do-directory-files-and-attributes-with-stat + (vec localname &optional id-format) + "Implement `directory-files-and-attributes' for Tramp files using stat(1) command." + (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) + (tramp-send-command-and-read + vec + (format + (concat + ;; We must care about filenames with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we + ;; quote the filenames via sed. + "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs " + "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s.0 \"%%A\" t %%i.0 -1)'); " + "echo \")\"") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command vec) + (tramp-get-remote-stat vec) + (if (eq id-format 'integer) "%u" "\"%U\"") + (if (eq id-format 'integer) "%g" "\"%G\"")))) + +;; This function should return "foo/" for directories and "bar" for +;; files. +(defun tramp-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (unless (save-match-data (string-match "/" filename)) + (with-parsed-tramp-file-name (expand-file-name directory) nil + + (all-completions + filename + (mapcar + 'list + (or + ;; Try cache first + (and + ;; Ignore if expired + (or (not (integerp tramp-completion-reread-directory-timeout)) + (<= (tramp-time-diff + (current-time) + (tramp-get-file-property + v localname "last-completion" '(0 0 0))) + tramp-completion-reread-directory-timeout)) + + ;; Try cache entries for filename, filename with last + ;; character removed, filename with last two characters + ;; removed, ..., and finally the empty string - all + ;; concatenated to the local directory name + + ;; This is inefficient for very long filenames, pity + ;; `reduce' is not available... + (car + (apply + 'append + (mapcar + (lambda (x) + (let ((cache-hit + (tramp-get-file-property + v + (concat localname (substring filename 0 x)) + "file-name-all-completions" + nil))) + (when cache-hit (list cache-hit)))) + (tramp-compat-number-sequence (length filename) 0 -1))))) + + ;; Cache expired or no matching cache entry found so we need + ;; to perform a remote operation + (let (result) + ;; Get a list of directories and files, including reliably + ;; tagging the directories with a trailing '/'. Because I + ;; rock. --daniel@danann.net + + ;; Changed to perform `cd' in the same remote op and only + ;; get entries starting with `filename'. Capture any `cd' + ;; error messages. Ensure any `cd' and `echo' aliases are + ;; ignored. + (tramp-send-command + v + (if (tramp-get-remote-perl v) + (progn + (tramp-maybe-send-script + v tramp-perl-file-name-all-completions + "tramp_perl_file_name_all_completions") + (format "tramp_perl_file_name_all_completions %s %s %d" + (tramp-shell-quote-argument localname) + (tramp-shell-quote-argument filename) + (if (symbol-value + ;; `read-file-name-completion-ignore-case' + ;; is introduced with Emacs 22.1. + (if (boundp + 'read-file-name-completion-ignore-case) + 'read-file-name-completion-ignore-case + 'completion-ignore-case)) + 1 0))) + + (format (concat + "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null" + ;; `ls' with wildcard might fail with `Argument + ;; list too long' error in some corner cases; if + ;; `ls' fails after `cd' succeeded, chances are + ;; that's the case, so let's retry without + ;; wildcard. This will return "too many" entries + ;; but that isn't harmful. + " || %s -a 2>/dev/null)" + " | while read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command v) + ;; When `filename' is empty, just `ls' without + ;; filename argument is more efficient than `ls *' + ;; for very large directories and might avoid the + ;; `Argument list too long' error. + ;; + ;; With and only with wildcard, we need to add + ;; `-d' to prevent `ls' from descending into + ;; sub-directories. + (if (zerop (length filename)) + "." + (concat (tramp-shell-quote-argument filename) "* -d")) + (tramp-get-ls-command v) + (tramp-get-test-command v)))) + + ;; Now grab the output. + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-max)) + + ;; Check result code, found in last line of output + (forward-line -1) + (if (looking-at "^fail$") + (progn + ;; Grab error message from line before last line + ;; (it was put there by `cd 2>&1') + (forward-line -1) + (tramp-error + v 'file-error + "tramp-handle-file-name-all-completions: %s" + (buffer-substring + (point) (tramp-compat-line-end-position)))) + ;; For peace of mind, if buffer doesn't end in `fail' + ;; then it should end in `ok'. If neither are in the + ;; buffer something went seriously wrong on the remote + ;; side. + (unless (looking-at "^ok$") + (tramp-error + v 'file-error + "\ +tramp-handle-file-name-all-completions: internal error accessing `%s': `%s'" + (tramp-shell-quote-argument localname) (buffer-string)))) + + (while (zerop (forward-line -1)) + (push (buffer-substring + (point) (tramp-compat-line-end-position)) + result))) + + ;; Because the remote op went through OK we know the + ;; directory we `cd'-ed to exists + (tramp-set-file-property + v localname "file-exists-p" t) + + ;; Because the remote op went through OK we know every + ;; file listed by `ls' exists. + (mapc (lambda (entry) + (tramp-set-file-property + v (concat localname entry) "file-exists-p" t)) + result) + + (tramp-set-file-property + v localname "last-completion" (current-time)) + + ;; Store result in the cache + (tramp-set-file-property + v (concat localname filename) + "file-name-all-completions" + result)))))))) + +(defun tramp-handle-file-name-completion + (filename directory &optional predicate) + "Like `file-name-completion' for Tramp files." + (unless (tramp-tramp-file-p directory) + (error + "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" + directory)) + (try-completion + filename + (mapcar 'list (file-name-all-completions filename directory)) + (when predicate + (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) + +;; cp, mv and ln + +(defun tramp-handle-add-name-to-file + (filename newname &optional ok-if-already-exists) + "Like `add-name-to-file' for Tramp files." + (unless (tramp-equal-remote filename newname) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (tramp-error + v 'file-error + "add-name-to-file: %s" + "only implemented for same method, same user, same host"))) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (let ((ln (when v1 (tramp-get-remote-ln v1)))) + (when (and (not ok-if-already-exists) + (file-exists-p newname) + (not (numberp ok-if-already-exists)) + (y-or-n-p + (format + "File %s already exists; make it a new name anyway? " + newname))) + (tramp-error + v2 'file-error + "add-name-to-file: file %s already exists" newname)) + (tramp-flush-file-property v2 (file-name-directory v2-localname)) + (tramp-flush-file-property v2 v2-localname) + (tramp-barf-unless-okay + v1 + (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) + (tramp-shell-quote-argument v2-localname)) + "error with add-name-to-file, see buffer `%s' for details" + (buffer-name)))))) + +(defun tramp-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + (cond + ;; At least one file a Tramp file? + ((or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context)) + ;; Compat section. + (preserve-selinux-context + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context))) + (preserve-uid-gid + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) + (t + (tramp-run-real-handler + 'copy-file (list filename newname ok-if-already-exists keep-date))))) + +(defun tramp-handle-copy-directory (dirname newname &optional keep-date parents) + "Like `copy-directory' for Tramp files." + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must have + ;; the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method (tramp-dissect-file-name dirname)) + (tramp-file-name-method (tramp-dissect-file-name newname))))) + ;; scp or rsync DTRT. + (progn + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (if (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname))) + (if (not (file-directory-p (file-name-directory newname))) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname keep-date)) + ;; We must do it file-wise. + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))))) + +(defun tramp-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + ;; Check if both files are local -- invoke normal rename-file. + ;; Otherwise, use Tramp from local system. + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists t t) + (tramp-run-real-handler + 'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-SELINUX-CONTEXT activates selinux commands. + +This function is invoked by `tramp-handle-copy-file' and +`tramp-handle-rename-file'. It is an error if OP is neither of `copy' +and `rename'. FILENAME and NEWNAME must be absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (context (and preserve-selinux-context + (apply 'file-selinux-context (list filename)))) + pr tm) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error + v 'file-already-exists "File %s already exists" newname)) + + (with-progress-reporter + v 0 (format "%s %s to %s" + (if (eq op 'copy) "Copying" "Renaming") + filename newname) + + (cond + ;; Both are Tramp files. + ((and t1 t2) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (cond + ;; Shortcut: if method, host, user are the same for + ;; both files, we invoke `cp' or `mv' on the remote + ;; host directly. + ((tramp-equal-remote filename newname) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; Try out-of-band operation. + ((tramp-method-out-of-band-p + v1 (nth 7 (file-attributes filename))) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname keep-date)) + + ;; No shortcut was possible. So we copy the file + ;; first. If the operation was `rename', we go back + ;; and delete the original file (if the copy was + ;; successful). The approach is simple-minded: we + ;; create a new buffer, insert the contents of the + ;; source file into it, then write out the buffer to + ;; the target file. The advantage is that it doesn't + ;; matter which filename handlers are used for the + ;; source and target file. + (t + (tramp-do-copy-or-rename-file-via-buffer + op filename newname keep-date)))))) + + ;; One file is a Tramp file, the other one is local. + ((or t1 t2) + (cond + ;; Fast track on local machine. + ((tramp-local-host-p v) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; If the Tramp file has an out-of-band method, the + ;; corresponding copy-program can be invoked. + ((tramp-method-out-of-band-p v (nth 7 (file-attributes filename))) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname keep-date)) + + ;; Use the inline method via a Tramp buffer. + (t (tramp-do-copy-or-rename-file-via-buffer + op filename newname keep-date)))) + + (t + ;; One of them must be a Tramp file. + (error "Tramp implementation says this cannot happen"))) + + ;; Handle `preserve-selinux-context'. + (when context (apply 'set-file-selinux-context (list newname context))) + + ;; In case of `rename', we must flush the cache of the source file. + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-property v1 (file-name-directory localname)) + (tramp-flush-file-property v1 localname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-property v2 (file-name-directory localname)) + (tramp-flush-file-property v2 localname))))))) + +(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) + "Use an Emacs buffer to copy or rename a file. +First arg OP is either `copy' or `rename' and indicates the operation. +FILENAME is the source file, NEWNAME the target file. +KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." + (with-temp-buffer + ;; We must disable multibyte, because binary data shall not be + ;; converted. + (set-buffer-multibyte nil) + (let ((coding-system-for-read 'binary) + (jka-compr-inhibit t)) + (insert-file-contents-literally filename)) + ;; We don't want the target file to be compressed, so we let-bind + ;; `jka-compr-inhibit' to t. + (let ((coding-system-for-write 'binary) + (jka-compr-inhibit t)) + (write-region (point-min) (point-max) newname))) + ;; KEEP-DATE handling. + (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))) + ;; Set the mode. + (set-file-modes newname (tramp-default-file-modes filename)) + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) (delete-file filename))) + +(defun tramp-do-copy-or-rename-file-directly + (op filename newname ok-if-already-exists keep-date preserve-uid-gid) + "Invokes `cp' or `mv' on the remote system. +OP must be one of `copy' or `rename', indicating `cp' or `mv', +respectively. FILENAME specifies the file to copy or rename, +NEWNAME is the name of the new file (for copy) or the new name of +the file (for rename). Both files must reside on the same host. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid from FILENAME." + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (file-times (nth 5 (file-attributes filename))) + (file-modes (tramp-default-file-modes filename))) + (with-parsed-tramp-file-name (if t1 filename newname) nil + (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") + ((eq op 'copy) "cp -f") + ((eq op 'rename) "mv -f") + (t (tramp-error + v 'file-error + "Unknown operation `%s', must be `copy' or `rename'" + op)))) + (localname1 + (if t1 + (tramp-file-name-handler 'file-remote-p filename 'localname) + filename)) + (localname2 + (if t2 + (tramp-file-name-handler 'file-remote-p newname 'localname) + newname)) + (prefix (file-remote-p (if t1 filename newname))) + cmd-result) + + (cond + ;; Both files are on a remote host, with same user. + ((and t1 t2) + (setq cmd-result + (tramp-send-command-and-check + v (format "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument localname2)))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (unless + (or + (and keep-date + ;; Mask cp -f error. + (re-search-forward + tramp-operation-not-permitted-regexp nil t)) + cmd-result) + (tramp-error-with-buffer + nil v 'file-error + "Copying directly failed, see buffer `%s' for details." + (buffer-name))))) + + ;; We are on the local host. + ((or t1 t2) + (cond + ;; We can do it directly. + ((let (file-name-handler-alist) + (and (file-readable-p localname1) + (file-writable-p (file-name-directory localname2)) + (or (file-directory-p localname2) + (file-writable-p localname2)))) + (if (eq op 'copy) + (tramp-compat-copy-file + localname1 localname2 ok-if-already-exists + keep-date preserve-uid-gid) + (tramp-run-real-handler + 'rename-file (list localname1 localname2 ok-if-already-exists)))) + + ;; We can do it directly with `tramp-send-command' + ((and (file-readable-p (concat prefix localname1)) + (file-writable-p + (file-name-directory (concat prefix localname2))) + (or (file-directory-p (concat prefix localname2)) + (file-writable-p (concat prefix localname2)))) + (tramp-do-copy-or-rename-file-directly + op (concat prefix localname1) (concat prefix localname2) + ok-if-already-exists keep-date t) + ;; We must change the ownership to the local user. + (tramp-set-file-uid-gid + (concat prefix localname2) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; We need a temporary file in between. + (t + ;; Create the temporary file. + (let ((tmpfile (tramp-compat-make-temp-file localname1))) + (unwind-protect + (progn + (cond + (t1 + (tramp-barf-unless-okay + v (format + "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument tmpfile)) + "Copying directly failed, see buffer `%s' for details." + (tramp-get-buffer v)) + ;; We must change the ownership as remote user. + ;; Since this does not work reliable, we also + ;; give read permissions. + (set-file-modes + (concat prefix tmpfile) + (tramp-compat-octal-to-decimal "0777")) + (tramp-set-file-uid-gid + (concat prefix tmpfile) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + (t2 + (if (eq op 'copy) + (tramp-compat-copy-file + localname1 tmpfile t + keep-date preserve-uid-gid) + (tramp-run-real-handler + 'rename-file + (list localname1 tmpfile t))) + ;; We must change the ownership as local user. + ;; Since this does not work reliable, we also + ;; give read permissions. + (set-file-modes + tmpfile (tramp-compat-octal-to-decimal "0777")) + (tramp-set-file-uid-gid + tmpfile + (tramp-get-remote-uid v 'integer) + (tramp-get-remote-gid v 'integer)))) + + ;; Move the temporary file to its destination. + (cond + (t2 + (tramp-barf-unless-okay + v (format + "cp -f -p %s %s" + (tramp-shell-quote-argument tmpfile) + (tramp-shell-quote-argument localname2)) + "Copying directly failed, see buffer `%s' for details." + (tramp-get-buffer v))) + (t1 + (tramp-run-real-handler + 'rename-file + (list tmpfile localname2 ok-if-already-exists))))) + + ;; Save exit. + (condition-case nil + (delete-file tmpfile) + (error))))))))) + + ;; Set the time and mode. Mask possible errors. + (condition-case nil + (when keep-date + (set-file-times newname file-times) + (set-file-modes newname file-modes)) + (error))))) + +(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) + "Invoke rcp program to copy. +The method used must be an out-of-band method." + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + copy-program copy-args copy-env copy-keep-date port spec + source target) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (if (and t1 t2) + + ;; Both are Tramp files. We shall optimize it, when the + ;; methods for filename and newname are the same. + (let* ((dir-flag (file-directory-p filename)) + (tmpfile (tramp-compat-make-temp-file localname dir-flag))) + (if dir-flag + (setq tmpfile + (expand-file-name + (file-name-nondirectory newname) tmpfile))) + (unwind-protect + (progn + (tramp-do-copy-or-rename-file-out-of-band + op filename tmpfile keep-date) + (tramp-do-copy-or-rename-file-out-of-band + 'rename tmpfile newname keep-date)) + ;; Save exit. + (condition-case nil + (if dir-flag + (tramp-compat-delete-directory + (expand-file-name ".." tmpfile) 'recursive) + (delete-file tmpfile)) + (error)))) + + ;; Expand hops. Might be necessary for gateway methods. + (setq v (car (tramp-compute-multi-hops v))) + (aset v 3 localname) + + ;; Check which ones of source and target are Tramp files. + (setq source (if t1 (tramp-make-copy-program-file-name v) filename) + target (funcall + (if (and (file-directory-p filename) + (string-equal + (file-name-nondirectory filename) + (file-name-nondirectory newname))) + 'file-name-directory + 'identity) + (if t2 (tramp-make-copy-program-file-name v) newname))) + + ;; Check for port number. Until now, there's no need for handling + ;; like method, user, host. + (setq host (tramp-file-name-real-host v) + port (tramp-file-name-port v) + port (or (and port (number-to-string port)) "")) + + ;; Compose copy command. + (setq spec (format-spec-make + ?h host ?u user ?p port + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" "") + ?k (if keep-date " " "")) + copy-program (tramp-get-method-parameter + method 'tramp-copy-program) + copy-keep-date (tramp-get-method-parameter + method 'tramp-copy-keep-date) + copy-args + (delq + nil + (mapcar + (lambda (x) + (setq + x + ;; " " is indication for keep-date argument. + (delete " " (mapcar (lambda (y) (format-spec y spec)) x))) + (unless (member "" x) (mapconcat 'identity x " "))) + (tramp-get-method-parameter method 'tramp-copy-args))) + copy-env + (delq + nil + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) (mapconcat 'identity x " "))) + (tramp-get-method-parameter method 'tramp-copy-env)))) + + ;; Check for program. + (when (and (fboundp 'executable-find) + (not (let ((default-directory + (tramp-compat-temporary-file-directory))) + (executable-find copy-program)))) + (tramp-error + v 'file-error "Cannot find copy program: %s" copy-program)) + + ;; Set variables for computing the prompt for reading + ;; password. + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-host v)) + + (unwind-protect + (with-temp-buffer + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if t1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + (while copy-env + (tramp-message v 5 "%s=\"%s\"" (car copy-env) (cadr copy-env)) + (setenv (pop copy-env) (pop copy-env))) + + ;; Use an asynchronous process. By this, password can + ;; be handled. The default directory must be local, in + ;; order to apply the correct `copy-program'. We don't + ;; set a timeout, because the copying of large files can + ;; last longer than 60 secs. + (let ((p (let ((default-directory + (tramp-compat-temporary-file-directory))) + (apply 'start-process + (tramp-get-connection-property + v "process-name" nil) + (tramp-get-connection-property + v "process-buffer" nil) + copy-program + (append copy-args (list source target)))))) + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v tramp-actions-copy-out-of-band)))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil)) + + ;; Handle KEEP-DATE argument. + (when (and keep-date (not copy-keep-date)) + (set-file-times newname (nth 5 (file-attributes filename)))) + + ;; Set the mode. + (unless (and keep-date copy-keep-date) + (ignore-errors + (set-file-modes newname (tramp-default-file-modes filename))))) + + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) + (if (file-regular-p filename) + (delete-file filename) + (tramp-compat-delete-directory filename 'recursive)))))) + +(defun tramp-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (setq dir (expand-file-name dir)) + (with-parsed-tramp-file-name dir nil + (tramp-flush-directory-property v (file-name-directory localname)) + (save-excursion + (tramp-barf-unless-okay + v (format "%s %s" + (if parents "mkdir -p" "mkdir") + (tramp-shell-quote-argument localname)) + "Couldn't make directory %s" dir)))) + +(defun tramp-handle-delete-directory (directory &optional recursive) + "Like `delete-directory' for Tramp files." + (setq directory (expand-file-name directory)) + (with-parsed-tramp-file-name directory nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname) + (tramp-barf-unless-okay + v (format "%s %s" + (if recursive "rm -rf" "rmdir") + (tramp-shell-quote-argument localname)) + "Couldn't delete %s" directory))) + +(defun tramp-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + (tramp-barf-unless-okay + v (format "%s %s" + (or (and trash (tramp-get-remote-trash v)) "rm -f") + (tramp-shell-quote-argument localname)) + "Couldn't delete %s" filename))) + +;; Dired. + +;; CCC: This does not seem to be enough. Something dies when +;; we try and delete two directories under Tramp :/ +(defun tramp-handle-dired-recursive-delete-directory (filename) + "Recursively delete the directory given. +This is like `dired-recursive-delete-directory' for Tramp files." + (with-parsed-tramp-file-name filename nil + ;; Run a shell command 'rm -r <localname>' + ;; Code shamelessly stolen from the dired implementation and, um, hacked :) + (unless (file-exists-p filename) + (tramp-error v 'file-error "No such directory: %s" filename)) + ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>) + (tramp-send-command + v + (format "rm -rf %s" (tramp-shell-quote-argument localname)) + ;; Don't read the output, do it explicitely. + nil t) + ;; Wait for the remote system to return to us... + ;; This might take a while, allow it plenty of time. + (tramp-wait-for-output (tramp-get-connection-process v) 120) + ;; Make sure that it worked... + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname) + (and (file-exists-p filename) + (tramp-error + v 'file-error "Failed to recursively delete %s" filename)))) + +(defun tramp-handle-dired-compress-file (file &rest ok-flag) + "Like `dired-compress-file' for Tramp files." + ;; OK-FLAG is valid for XEmacs only, but not implemented. + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-property v localname) + (save-excursion + (let ((suffixes + (if (not (featurep 'xemacs)) + ;; Emacs case + (symbol-value 'dired-compress-file-suffixes) + ;; XEmacs has `dired-compression-method-alist', which is + ;; transformed into `dired-compress-file-suffixes' structure. + (mapcar + (lambda (x) + (list (concat (regexp-quote (nth 1 x)) "\\'") + nil + (mapconcat 'identity (nth 3 x) " "))) + (symbol-value 'dired-compression-method-alist)))) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) + nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-progress-reporter v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname))) + ;; `dired-remove-file' is not defined in XEmacs. + (tramp-compat-funcall 'dired-remove-file file) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so compress it. + ;; Try gzip. + (with-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (concat "gzip -f " + (tramp-shell-quote-argument localname))) + ;; `dired-remove-file' is not defined in XEmacs. + (tramp-compat-funcall 'dired-remove-file file) + (cond ((file-exists-p (concat file ".gz")) + (concat file ".gz")) + ((file-exists-p (concat file ".z")) + (concat file ".z")) + (t nil)))))))))) + +(defun tramp-handle-dired-uncache (dir &optional dir-p) + "Like `dired-uncache' for Tramp files." + ;; DIR-P is valid for XEmacs only. + (with-parsed-tramp-file-name + (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil + (tramp-flush-directory-property v localname))) + +(defun tramp-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (if (and (featurep 'ls-lisp) + (not (symbol-value 'ls-lisp-use-insert-directory-program))) + (tramp-run-real-handler + 'insert-directory (list filename switches wildcard full-directory-p)) + (when (stringp switches) + (setq switches (split-string switches))) + (when (and (member "--dired" switches) + (not (tramp-get-ls-command-with-dired v))) + (setq switches (delete "--dired" switches))) + (when wildcard + (setq wildcard (tramp-run-real-handler + 'file-name-nondirectory (list localname))) + (setq localname (tramp-run-real-handler + 'file-name-directory (list localname)))) + (unless full-directory-p + (setq switches (add-to-list 'switches "-d" 'append))) + (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) + (when wildcard + (setq switches (concat switches " " wildcard))) + (tramp-message + v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s" + switches filename (if wildcard "yes" "no") + (if full-directory-p "yes" "no")) + ;; If `full-directory-p', we just say `ls -l FILENAME'. + ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. + (if full-directory-p + (tramp-send-command + v + (format "%s %s %s 2>/dev/null" + (tramp-get-ls-command v) + switches + (if wildcard + localname + (tramp-shell-quote-argument (concat localname "."))))) + (tramp-barf-unless-okay + v + (format "cd %s" (tramp-shell-quote-argument + (tramp-run-real-handler + 'file-name-directory (list localname)))) + "Couldn't `cd %s'" + (tramp-shell-quote-argument + (tramp-run-real-handler 'file-name-directory (list localname)))) + (tramp-send-command + v + (format "%s %s %s" + (tramp-get-ls-command v) + switches + (if (or wildcard + (zerop (length + (tramp-run-real-handler + 'file-name-nondirectory (list localname))))) + "" + (tramp-shell-quote-argument + (tramp-run-real-handler + 'file-name-nondirectory (list localname))))))) + (let ((beg (point))) + ;; We cannot use `insert-buffer-substring' because the Tramp + ;; buffer changes its contents before insertion due to calling + ;; `expand-file' and alike. + (insert + (with-current-buffer (tramp-get-buffer v) + (buffer-string))) + + ;; Check for "--dired" output. + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (forward-line -1)) + (when (looking-at "//DIRED//\\s-+") + (let ((databeg (match-end 0)) + (end (tramp-compat-line-end-position))) + ;; Now read the numeric positions of file names. + (goto-char databeg) + (while (< (point) end) + (let ((start (+ beg (read (current-buffer)))) + (end (+ beg (read (current-buffer))))) + (if (memq (char-after end) '(?\n ?\ )) + ;; End is followed by \n or by " -> ". + (put-text-property start end 'dired-filename t)))))) + ;; Remove trailing lines. + (goto-char (tramp-compat-line-beginning-position)) + (while (looking-at "//") + (forward-line 1) + (delete-region (match-beginning 0) (point))) + + ;; The inserted file could be from somewhere else. + (when (and (not wildcard) (not full-directory-p)) + (goto-char (point-max)) + (when (file-symlink-p filename) + (goto-char (search-backward "->" beg 'noerror))) + (search-backward + (if (zerop (length (file-name-nondirectory filename))) + "." + (file-name-nondirectory filename)) + beg 'noerror) + (replace-match (file-relative-name filename) t)) + + (goto-char (point-max)))))) + +(defun tramp-handle-unhandled-file-name-directory (filename) + "Like `unhandled-file-name-directory' for Tramp files." + ;; With Emacs 23, we could simply return `nil'. But we must keep it + ;; for backward compatibility. + (expand-file-name "~/")) + +;; Canonicalization of file names. + +(defun tramp-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files. +If the localname part of the given filename starts with \"/../\" then +the result will be a local, non-Tramp, filename." + ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". + (setq dir (or dir default-directory "/")) + ;; Unless NAME is absolute, concat DIR and NAME. + (unless (file-name-absolute-p name) + (setq name (concat (file-name-as-directory dir) name))) + ;; If NAME is not a Tramp file, run the real handler. + (if (not (tramp-connectable-p name)) + (tramp-run-real-handler 'expand-file-name (list name nil)) + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (setq localname (concat "~/" localname))) + ;; Tilde expansion if necessary. This needs a shell which + ;; groks tilde expansion! The function `tramp-find-shell' is + ;; supposed to find such a shell on the remote host. Please + ;; tell me about it when this doesn't work on your system. + (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname))) + ;; We cannot simply apply "~/", because under sudo "~/" is + ;; expanded to the local user home directory but to the + ;; root home directory. On the other hand, using always + ;; the default user name for tilde expansion is not + ;; appropriate either, because ssh and companions might + ;; use a user name from the config file. + (when (and (string-equal uname "~") + (string-match "\\`su\\(do\\)?\\'" method)) + (setq uname (concat uname user))) + (setq uname + (with-connection-property v uname + (tramp-send-command + v (format "cd %s; pwd" (tramp-shell-quote-argument uname))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (buffer-substring + (point) (tramp-compat-line-end-position))))) + (setq localname (concat uname fname)))) + ;; There might be a double slash, for example when "~/" + ;; expands to "/". Remove this. + (while (string-match "//" localname) + (setq localname (replace-match "/" t t localname))) + ;; No tilde characters in file name, do normal + ;; `expand-file-name' (this does "/./" and "/../"). We bind + ;; `directory-sep-char' here for XEmacs on Windows, which would + ;; otherwise use backslash. `default-directory' is bound, + ;; because on Windows there would be problems with UNC shares or + ;; Cygwin mounts. + (let ((directory-sep-char ?/) + (default-directory (tramp-compat-temporary-file-directory))) + (tramp-make-tramp-file-name + method user host + (tramp-drop-volume-letter + (tramp-run-real-handler + 'expand-file-name (list localname)))))))) + +(defun tramp-handle-substitute-in-file-name (filename) + "Like `substitute-in-file-name' for Tramp files. +\"//\" and \"/~\" substitute only in the local filename part. +If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at +beginning of local filename are not substituted." + ;; First, we must replace environment variables. + (setq filename (tramp-replace-environment-variables filename)) + (with-parsed-tramp-file-name filename nil + (if (equal tramp-syntax 'url) + ;; We need to check localname only. The other parts cannot contain + ;; "//" or "/~". + (if (and (> (length localname) 1) + (or (string-match "//" localname) + (string-match "/~" localname 1))) + (tramp-run-real-handler 'substitute-in-file-name (list filename)) + (tramp-make-tramp-file-name + (when method (substitute-in-file-name method)) + (when user (substitute-in-file-name user)) + (when host (substitute-in-file-name host)) + (when localname + (tramp-run-real-handler + 'substitute-in-file-name (list localname))))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) + (setq filename + (concat (file-remote-p filename) + (replace-match "\\1" nil nil localname))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (when (string-match "~$" filename) + (setq filename (concat filename "/")))) + (tramp-run-real-handler 'substitute-in-file-name (list filename))))) + +;;; Remote commands: + +(defun tramp-handle-executable-find (command) + "Like `executable-find' for Tramp files." + (with-parsed-tramp-file-name default-directory nil + (tramp-find-executable v command (tramp-get-remote-path v) t))) + +(defun tramp-process-sentinel (proc event) + "Flush file caches." + (unless (memq (process-status proc) '(run open)) + (let ((vec (tramp-get-connection-property proc "vector" nil))) + (when vec + (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event) + (tramp-flush-directory-property vec ""))))) + +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-handle-start-file-process (name buffer program &rest args) + "Like `start-file-process' for Tramp files." + (with-parsed-tramp-file-name default-directory nil + (unwind-protect + ;; When PROGRAM is nil, we just provide a tty. + (let ((command + (when (stringp program) + (format "cd %s; exec %s" + (tramp-shell-quote-argument localname) + (mapconcat 'tramp-shell-quote-argument + (cons program args) " ")))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (name1 name) + (i 0)) + (unless buffer + ;; BUFFER can be nil. We use a temporary buffer. + (setq buffer (generate-new-buffer tramp-temp-buffer-name))) + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + ;; Activate narrowing in order to save BUFFER contents. + ;; Clear also the modification time; otherwise we might be + ;; interrupted by `verify-visited-file-modtime'. + (with-current-buffer (tramp-get-connection-buffer v) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max))) + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (tramp-maybe-open-connection v) + (unless (tramp-compat-process-get + (tramp-get-connection-process v) 'remote-tty) + (tramp-error + v 'file-error "pty association is not supported for `%s'" name))) + (let ((p (tramp-get-connection-process v))) + ;; Set sentinel and query flag for this process. + (tramp-set-connection-property p "vector" v) + (set-process-sentinel p 'tramp-process-sentinel) + (tramp-set-process-query-on-exit-flag p t) + ;; Return process. + p)) + ;; Save exit. + (with-current-buffer (tramp-get-connection-buffer v) + (if (string-match tramp-temp-buffer-name (buffer-name)) + (progn + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (widen) + (goto-char (point-max)))) + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil)))) + +(defun tramp-handle-process-file + (program &optional infile destination display &rest args) + "Like `process-file' for Tramp files." + ;; The implementation is not complete yet. + (when (and (numberp destination) (zerop destination)) + (error "Implementation does not handle immediate return")) + + (with-parsed-tramp-file-name default-directory nil + (let (command input tmpinput stderr tmpstderr outbuf ret) + ;; Compute command. + (setq command (mapconcat 'tramp-shell-quote-argument + (cons program args) " ")) + ;; Determine input. + (if (null infile) + (setq input "/dev/null") + (setq infile (expand-file-name infile)) + (if (tramp-equal-remote default-directory infile) + ;; INFILE is on the same remote host. + (setq input (with-parsed-tramp-file-name infile nil localname)) + ;; INFILE must be copied to remote host. + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name method user host input)) + (copy-file infile tmpinput t))) + (when input (setq command (format "%s <%s" command input))) + + ;; Determine output. + (cond + ;; Just a buffer. + ((bufferp destination) + (setq outbuf destination)) + ;; A buffer name. + ((stringp destination) + (setq outbuf (get-buffer-create destination))) + ;; (REAL-DESTINATION ERROR-DESTINATION) + ((consp destination) + ;; output. + (cond + ((bufferp (car destination)) + (setq outbuf (car destination))) + ((stringp (car destination)) + (setq outbuf (get-buffer-create (car destination)))) + ((car destination) + (setq outbuf (current-buffer)))) + ;; stderr. + (cond + ((stringp (cadr destination)) + (setcar (cdr destination) (expand-file-name (cadr destination))) + (if (tramp-equal-remote default-directory (cadr destination)) + ;; stderr is on the same remote host. + (setq stderr (with-parsed-tramp-file-name + (cadr destination) nil localname)) + ;; stderr must be copied to remote host. The temporary + ;; file must be deleted after execution. + (setq stderr (tramp-make-tramp-temp-file v) + tmpstderr (tramp-make-tramp-file-name + method user host stderr)))) + ;; stderr to be discarded. + ((null (cadr destination)) + (setq stderr "/dev/null")))) + ;; 't + (destination + (setq outbuf (current-buffer)))) + (when stderr (setq command (format "%s 2>%s" command stderr))) + + ;; Send the command. It might not return in time, so we protect + ;; it. Call it in a subshell, in order to preserve working + ;; directory. + (condition-case nil + (unwind-protect + (setq ret + (if (tramp-send-command-and-check + v (format "\\cd %s; %s" + (tramp-shell-quote-argument localname) + command) + t t) + 0 1)) + ;; We should show the output anyway. + (when outbuf + (with-current-buffer outbuf + (insert + (with-current-buffer (tramp-get-connection-buffer v) + (buffer-string)))) + (when display (display-buffer outbuf)))) + ;; When the user did interrupt, we should do it also. We use + ;; return code -1 as marker. + (quit + (kill-buffer (tramp-get-connection-buffer v)) + (setq ret -1)) + ;; Handle errors. + (error + (kill-buffer (tramp-get-connection-buffer v)) + (setq ret 1))) + + ;; Provide error file. + (when tmpstderr (rename-file tmpstderr (cadr destination) t)) + + ;; Cleanup. We remove all file cache values for the connection, + ;; because the remote process could have changed them. + (when tmpinput (delete-file tmpinput)) + + ;; `process-file-side-effects' has been introduced with GNU + ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; by `program'. If it doesn't exist, we assume its default + ;; value 't'. + (unless (and (boundp 'process-file-side-effects) + (not (symbol-value 'process-file-side-effects))) + (tramp-flush-directory-property v "")) + + ;; Return exit status. + (if (equal ret -1) + (keyboard-quit) + ret)))) + +(defun tramp-handle-call-process-region + (start end program &optional delete buffer display &rest args) + "Like `call-process-region' for Tramp files." + (let ((tmpfile (tramp-compat-make-temp-file ""))) + (write-region start end tmpfile) + (when delete (delete-region start end)) + (unwind-protect + (apply 'call-process program tmpfile buffer display args) + (delete-file tmpfile)))) + +(defun tramp-handle-shell-command + (command &optional output-buffer error-buffer) + "Like `shell-command' for Tramp files." + (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) + ;; We cannot use `shell-file-name' and `shell-command-switch', + ;; they are variables of the local host. + (args (list + (tramp-get-method-parameter + (tramp-file-name-method + (tramp-dissect-file-name default-directory)) + 'tramp-remote-sh) + "-c" (substring command 0 asynchronous))) + current-buffer-p + (output-buffer + (cond + ((bufferp output-buffer) output-buffer) + ((stringp output-buffer) (get-buffer-create output-buffer)) + (output-buffer + (setq current-buffer-p t) + (current-buffer)) + (t (get-buffer-create + (if asynchronous + "*Async Shell Command*" + "*Shell Command Output*"))))) + (error-buffer + (cond + ((bufferp error-buffer) error-buffer) + ((stringp error-buffer) (get-buffer-create error-buffer)))) + (buffer + (if (and (not asynchronous) error-buffer) + (with-parsed-tramp-file-name default-directory nil + (list output-buffer (tramp-make-tramp-temp-file v))) + output-buffer)) + (p (get-buffer-process output-buffer))) + + ;; Check whether there is another process running. Tramp does not + ;; support 2 (asynchronous) processes in parallel. + (when p + (if (yes-or-no-p "A command is running. Kill it? ") + (ignore-errors (kill-process p)) + (error "Shell command in progress"))) + + (if current-buffer-p + (progn + (barf-if-buffer-read-only) + (push-mark nil t)) + (with-current-buffer output-buffer + (setq buffer-read-only nil) + (erase-buffer))) + + (if (and (not current-buffer-p) (integerp asynchronous)) + (prog1 + ;; Run the process. + (apply 'start-file-process "*Async Shell*" buffer args) + ;; Display output. + (pop-to-buffer output-buffer) + (setq mode-line-process '(":%s")) + (shell-mode)) + + (prog1 + ;; Run the process. + (apply 'process-file (car args) nil buffer nil (cdr args)) + ;; Insert error messages if they were separated. + (when (listp buffer) + (with-current-buffer error-buffer + (insert-file-contents (cadr buffer))) + (delete-file (cadr buffer))) + (if current-buffer-p + ;; This is like exchange-point-and-mark, but doesn't + ;; activate the mark. It is cleaner to avoid activation, + ;; even though the command loop would deactivate the mark + ;; because we inserted text. + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; There's some output, display it. + (when (with-current-buffer output-buffer (> (point-max) (point-min))) + (if (functionp 'display-message-or-buffer) + (tramp-compat-funcall 'display-message-or-buffer output-buffer) + (pop-to-buffer output-buffer)))))))) + +(defun tramp-handle-file-local-copy (filename) + "Like `file-local-copy' for Tramp files." + + (with-parsed-tramp-file-name filename nil + (unless (file-exists-p filename) + (tramp-error + v 'file-error + "Cannot make local copy of non-existing file `%s'" filename)) + + (let* ((size (nth 7 (file-attributes filename))) + (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) + (loc-dec (tramp-get-inline-coding v "local-decoding" size)) + (tmpfile (tramp-compat-make-temp-file filename))) + + (condition-case err + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (copy-file filename tmpfile t t)) + + ;; Use inline encoding for file transfer. + (rem-enc + (save-excursion + (with-progress-reporter + v 3 (format "Encoding remote file %s" filename) + (tramp-barf-unless-okay + v (format rem-enc (tramp-shell-quote-argument localname)) + "Encoding remote file failed")) + + (if (functionp loc-dec) + ;; If local decoding is a function, we call it. We + ;; must disable multibyte, because + ;; `uudecode-decode-region' doesn't handle it + ;; correctly. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (with-progress-reporter + v 3 (format "Decoding remote file %s with function %s" + filename loc-dec) + (funcall loc-dec (point-min) (point-max)) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (write-region (point-min) (point-max) tmpfile)))) + + ;; If tramp-decoding-function is not defined for this + ;; method, we invoke tramp-decoding-command instead. + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (write-region (point-min) (point-max) tmpfile2)) + (with-progress-reporter + v 3 (format "Decoding remote file %s with command %s" + filename loc-dec) + (unwind-protect + (tramp-call-local-coding-command + loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))))) + + ;; Set proper permissions. + (set-file-modes tmpfile (tramp-default-file-modes filename)) + ;; Set local user ownership. + (tramp-set-file-uid-gid tmpfile))) + + ;; Oops, I don't know what to do. + (t (tramp-error + v 'file-error "Wrong method specification for `%s'" method))) + + ;; Error handling. + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + (run-hooks 'tramp-handle-file-local-copy-hook) + tmpfile))) + +(defun tramp-handle-file-remote-p (filename &optional identification connected) + "Like `file-remote-p' for Tramp files." + (let ((tramp-verbose 3)) + (when (tramp-tramp-file-p filename) + (let* ((v (tramp-dissect-file-name filename)) + (p (tramp-get-connection-process v)) + (c (and p (processp p) (memq (process-status p) '(run open))))) + ;; We expand the file name only, if there is already a connection. + (with-parsed-tramp-file-name + (if c (expand-file-name filename) filename) nil + (and (or (not connected) c) + (cond + ((eq identification 'method) method) + ((eq identification 'user) user) + ((eq identification 'host) host) + ((eq identification 'localname) localname) + (t (tramp-make-tramp-file-name method user host ""))))))))) + +(defun tramp-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (barf-if-buffer-read-only) + (setq filename (expand-file-name filename)) + (let (result local-copy remote-copy) + (with-parsed-tramp-file-name filename nil + (unwind-protect + (if (not (file-exists-p filename)) + ;; We don't raise a Tramp error, because it might be + ;; suppressed, like in `find-file-noselect-1'. + (signal 'file-error + (list "File not found on remote host" filename)) + + (if (and (tramp-local-host-p v) + (let (file-name-handler-alist) + (file-readable-p localname))) + ;; Short track: if we are on the local host, we can + ;; run directly. + (setq result + (tramp-run-real-handler + 'insert-file-contents + (list localname visit beg end replace))) + + ;; When we shall insert only a part of the file, we copy + ;; this part. + (when (or beg end) + (setq remote-copy (tramp-make-tramp-temp-file v)) + (tramp-send-command + v + (cond + ((and beg end) + (format "tail -c +%d %s | head -c +%d >%s" + (1+ beg) (tramp-shell-quote-argument localname) + (- end beg) remote-copy)) + (beg + (format "tail -c +%d %s >%s" + (1+ beg) (tramp-shell-quote-argument localname) + remote-copy)) + (end + (format "head -c +%d %s >%s" + (1+ end) (tramp-shell-quote-argument localname) + remote-copy))))) + + ;; `insert-file-contents-literally' takes care to avoid + ;; calling jka-compr. By let-binding + ;; `inhibit-file-name-operation', we propagate that care + ;; to the `file-local-copy' operation. + (setq local-copy + (let ((inhibit-file-name-operation + (when (eq inhibit-file-name-operation + 'insert-file-contents) + 'file-local-copy))) + (cond + ((stringp remote-copy) + (file-local-copy + (tramp-make-tramp-file-name + method user host remote-copy))) + ((stringp tramp-temp-buffer-file-name) + (copy-file filename tramp-temp-buffer-file-name 'ok) + tramp-temp-buffer-file-name) + (t (file-local-copy filename))))) + + ;; When the file is not readable for the owner, it + ;; cannot be inserted, even it is redable for the group + ;; or for everybody. + (set-file-modes local-copy (tramp-compat-octal-to-decimal "0600")) + + (when (and (null remote-copy) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + ;; We keep the local file for performance reasons, + ;; useful for "rsync". + (setq tramp-temp-buffer-file-name local-copy) + (put 'tramp-temp-buffer-file-name 'permanent-local t)) + + (with-progress-reporter + v 3 (format "Inserting local temp file `%s'" local-copy) + ;; We must ensure that `file-coding-system-alist' + ;; matches `local-copy'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist + filename local-copy))) + (setq result + (insert-file-contents + local-copy nil nil nil replace)))))) + + ;; Save exit. + (progn + (when visit + (setq buffer-file-name filename) + (setq buffer-read-only (not (file-writable-p filename))) + (set-visited-file-modtime) + (set-buffer-modified-p nil)) + (when (and (stringp local-copy) + (or remote-copy (null tramp-temp-buffer-file-name))) + (delete-file local-copy)) + (when (stringp remote-copy) + (delete-file + (tramp-make-tramp-file-name method user host remote-copy)))))) + + ;; Result. + (list (expand-file-name filename) + (cadr result)))) + +;; This is needed for XEmacs only. Code stolen from files.el. +(defun tramp-handle-insert-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally' for Tramp files." + (let ((format-alist nil) + (after-insert-file-functions nil) + (coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil)) + (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) + (inhibit-file-name-operation 'insert-file-contents)) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + ;; Save exit. + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + +(defun tramp-handle-find-backup-file-name (filename) + "Like `find-backup-file-name' for Tramp files." + (with-parsed-tramp-file-name filename nil + ;; We set both variables. It doesn't matter whether it is + ;; Emacs or XEmacs. + (let ((backup-directory-alist + ;; Emacs case. + (when (boundp 'backup-directory-alist) + (if (symbol-value 'tramp-backup-directory-alist) + (mapcar + (lambda (x) + (cons + (car x) + (if (and (stringp (cdr x)) + (file-name-absolute-p (cdr x)) + (not (tramp-file-name-p (cdr x)))) + (tramp-make-tramp-file-name method user host (cdr x)) + (cdr x)))) + (symbol-value 'tramp-backup-directory-alist)) + (symbol-value 'backup-directory-alist)))) + + (bkup-backup-directory-info + ;; XEmacs case. + (when (boundp 'bkup-backup-directory-info) + (if (symbol-value 'tramp-bkup-backup-directory-info) + (mapcar + (lambda (x) + (nconc + (list (car x)) + (list + (if (and (stringp (car (cdr x))) + (file-name-absolute-p (car (cdr x))) + (not (tramp-file-name-p (car (cdr x))))) + (tramp-make-tramp-file-name + method user host (car (cdr x))) + (car (cdr x)))) + (cdr (cdr x)))) + (symbol-value 'tramp-bkup-backup-directory-info)) + (symbol-value 'bkup-backup-directory-info))))) + + (tramp-run-real-handler 'find-backup-file-name (list filename))))) + +(defun tramp-handle-make-auto-save-file-name () + "Like `make-auto-save-file-name' for Tramp files. +Returns a file name in `tramp-auto-save-directory' for autosaving this file." + (let ((tramp-auto-save-directory tramp-auto-save-directory) + (buffer-file-name + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + (buffer-file-name)))) + ;; File name must be unique. This is ensured with Emacs 22 (see + ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for + ;; all other cases we must do it ourselves. + (when (boundp 'auto-save-file-name-transforms) + (mapc + (lambda (x) + (when (and (string-match (car x) buffer-file-name) + (not (car (cddr x)))) + (setq tramp-auto-save-directory + (or tramp-auto-save-directory + (tramp-compat-temporary-file-directory))))) + (symbol-value 'auto-save-file-name-transforms))) + ;; Create directory. + (when tramp-auto-save-directory + (setq buffer-file-name + (expand-file-name buffer-file-name tramp-auto-save-directory)) + (unless (file-exists-p tramp-auto-save-directory) + (make-directory tramp-auto-save-directory t))) + ;; Run plain `make-auto-save-file-name'. There might be an advice when + ;; it is not a magic file name operation (since Emacs 22). + ;; We must deactivate it temporarily. + (if (not (ad-is-active 'make-auto-save-file-name)) + (tramp-run-real-handler 'make-auto-save-file-name nil) + ;; else + (ad-deactivate 'make-auto-save-file-name) + (prog1 + (tramp-run-real-handler 'make-auto-save-file-name nil) + (ad-activate 'make-auto-save-file-name))))) + +(defvar tramp-handle-write-region-hook nil + "Normal hook to be run at the end of `tramp-handle-write-region'.") + +;; CCC grok LOCKNAME +(defun tramp-handle-write-region + (start end filename &optional append visit lockname confirm) + "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + ;; Following part commented out because we don't know what to do about + ;; file locking, and it does not appear to be a problem to ignore it. + ;; Ange-ftp ignores it, too. + ;; (when (and lockname (stringp lockname)) + ;; (setq lockname (expand-file-name lockname))) + ;; (unless (or (eq lockname nil) + ;; (string= lockname filename)) + ;; (error + ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME")) + + ;; XEmacs takes a coding system as the seventh argument, not `confirm'. + (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) + (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) + (tramp-error v 'file-error "File not overwritten"))) + + (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) + + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (let (file-name-handler-alist) + (and + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))))) + ;; Short track: if we are on the local host, we can run directly. + (tramp-run-real-handler + 'write-region + (list start end localname append 'no-message lockname confirm)) + + (let ((modes (save-excursion (tramp-default-file-modes filename))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp + ;; file. At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic + ;; simpler. + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) + + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when append (copy-file filename tmpfile 'ok)) + + ;; We say `no-message' here because we don't want the + ;; visited file modtime data to be clobbered from the temp + ;; file. We call `set-visited-file-modtime' ourselves later + ;; on. We must ensure that `file-coding-system-alist' + ;; matches `tmpfile'. + (let (file-name-handler-alist + (file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile))) + (condition-case err + (tramp-run-real-handler + 'write-region + (list start end tmpfile append 'no-message lockname confirm)) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Now, `last-coding-system-used' has the right value. Remember it. + (when (boundp 'last-coding-system-used) + (setq coding-system-used + (symbol-value 'last-coding-system-used)))) + + ;; The permissions of the temporary file should be set. If + ;; filename does not exist (eq modes nil) it has been + ;; renamed to the backup file. This case `save-buffer' + ;; handles permissions. + ;; Ensure, that it is still readable. + (when modes + (set-file-modes + tmpfile + (logior (or modes 0) (tramp-compat-octal-to-decimal "0400")))) + + ;; This is a bit lengthy due to the different methods + ;; possible for file transfer. First, we check whether the + ;; method uses an rcp program. If so, we call it. + ;; Otherwise, both encoding and decoding command must be + ;; specified. However, if the method _also_ specifies an + ;; encoding function, then that is used for encoding the + ;; contents of the tmp file. + (let* ((size (nth 7 (file-attributes tmpfile))) + (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) + (loc-enc (tramp-get-inline-coding v "local-encoding" size))) + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. + (unwind-protect + (copy-file tmpfile filename t) + (delete-file tmpfile)))) + + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (unwind-protect + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (if (functionp loc-enc) + (with-progress-reporter + v 3 (format "Encoding region using function `%s'" + loc-enc) + (let ((coding-system-for-read 'binary)) + (insert-file-contents-literally tmpfile)) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (funcall loc-enc (point-min) (point-max)))) + + (with-progress-reporter + v 3 (format "Encoding region using command `%s'" + loc-enc) + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-progress-reporter + v 3 + (format "Decoding region into remote file %s" filename) + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-send-command + v + (format + (concat rem-dec " <<'EOF'\n%sEOF") + (tramp-shell-quote-argument localname) + (buffer-string))) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-compat-call-process "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v + (format + "cksum <%s" (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (with-current-buffer (tramp-get-buffer v) + (buffer-string)))) + (tramp-error + v 'file-error + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") + filename rem-dec))))) + + ;; Save exit. + (delete-file tmpfile))) + + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an rcp program") + method)))) + + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (set 'last-coding-system-used coding-system-used)))) + + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + + ;; We must protect `last-coding-system-used', now we have set it + ;; to its correct value. + (let (last-coding-system-used (need-chown t)) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (let ((file-attr (file-attributes filename))) + (set-visited-file-modtime + ;; We must pass modtime explicitely, because filename can + ;; be different from (buffer-file-name), f.e. if + ;; `file-precious-flag' is set. + (nth 5 file-attr)) + (when (and (eq (nth 2 file-attr) uid) + (eq (nth 3 file-attr) gid)) + (setq need-chown nil)))) + + ;; Set the ownership. + (when need-chown + (tramp-set-file-uid-gid filename uid gid)) + (when (or (eq visit t) (null visit) (stringp visit)) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook))))) + +(defvar tramp-vc-registered-file-names nil + "List used to collect file names, which are checked during `vc-registered'.") + +;; VC backends check for the existence of various different special +;; files. This is very time consuming, because every single check +;; requires a remote command (the file cache must be invalidated). +;; Therefore, we apply a kind of optimization. We install the file +;; name handler `tramp-vc-file-name-handler', which does nothing but +;; remembers all file names for which `file-exists-p' or +;; `file-readable-p' has been applied. A first run of `vc-registered' +;; is performed. Afterwards, a script is applied for all collected +;; file names, using just one remote command. The result of this +;; script is used to fill the file cache with actual values. Now we +;; can reset the file name handlers, and we make a second run of +;; `vc-registered', which returns the expected result without sending +;; any other remote command. +(defun tramp-handle-vc-registered (file) + "Like `vc-registered' for Tramp files." + (tramp-compat-with-temp-message "" + (with-parsed-tramp-file-name file nil + (with-progress-reporter + v 3 (format "Checking `vc-registered' for %s" file) + + ;; There could be new files, created by the vc backend. We + ;; cannot reuse the old cache entries, therefore. + (let (tramp-vc-registered-file-names + (tramp-cache-inhibit-cache (current-time)) + (file-name-handler-alist + `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) + + ;; Here we collect only file names, which need an operation. + (tramp-run-real-handler 'vc-registered (list file)) + (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) + + ;; Send just one command, in order to fill the cache. + (when tramp-vc-registered-file-names + (tramp-maybe-send-script + v + (format tramp-vc-registered-read-file-names + (tramp-get-file-exists-command v) + (format "%s -r" (tramp-get-test-command v))) + "tramp_vc_registered_read_file_names") + + (dolist + (elt + (tramp-send-command-and-read + v + (format + "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" + (mapconcat 'tramp-shell-quote-argument + tramp-vc-registered-file-names + "\n")))) + + (tramp-set-file-property + v (car elt) (cadr elt) (cadr (cdr elt)))))) + + ;; Second run. Now all `file-exists-p' or `file-readable-p' + ;; calls shall be answered from the file cache. We unset + ;; `process-file-side-effects' in order to keep the cache when + ;; `process-file' calls appear. + (let (process-file-side-effects) + (tramp-run-real-handler 'vc-registered (list file))))))) + +;;;###tramp-autoload +(defun tramp-sh-file-name-handler (operation &rest args) + "Invoke remote-shell Tramp file name handler. +Fall back to normal file name handler if no Tramp handler exists." + (when (and tramp-locked (not tramp-locker)) + (setq tramp-locked nil) + (signal 'file-error (list "Forbidden reentrant call of Tramp"))) + (let ((tl tramp-locked)) + (unwind-protect + (progn + (setq tramp-locked t) + (let ((tramp-locker t)) + (save-match-data + (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if fn + (apply (cdr fn) args) + (tramp-run-real-handler operation args)))))) + (setq tramp-locked tl)))) + +(defun tramp-vc-file-name-handler (operation &rest args) + "Invoke special file name handler, which collects files to be handled." + (save-match-data + (let ((filename + (tramp-replace-environment-variables + (apply 'tramp-file-name-for-operation operation args))) + (fn (assoc operation tramp-sh-file-name-handler-alist))) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume, that VC uses only `file-exists-p' and + ;; `file-readable-p' checks; otherwise we must extend the + ;; list. We do not perform any action, but return nil, in + ;; order to keep `vc-registered' running. + ((and fn (memq operation '(file-exists-p file-readable-p))) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (fn + (save-match-data (apply (cdr fn) args))) + ;; Default file name handlers, we don't care. + (t (tramp-run-real-handler operation args))))))) + +;;; Internal Functions: + +(defun tramp-maybe-send-script (vec script name) + "Define in remote shell function NAME implemented as SCRIPT. +Only send the definition if it has not already been done." + (let* ((p (tramp-get-connection-process vec)) + (scripts (tramp-get-connection-property p "scripts" nil))) + (unless (member name scripts) + (with-progress-reporter vec 5 (format "Sending script `%s'" name) + ;; The script could contain a call of Perl. This is masked with `%s'. + (tramp-barf-unless-okay + vec + (format "%s () {\n%s\n}" name + (format script (tramp-get-remote-perl vec))) + "Script %s sending failed" name) + (tramp-set-connection-property p "scripts" (cons name scripts)))))) + +(defun tramp-set-auto-save () + (when (and ;; ange-ftp has its own auto-save mechanism + (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) + 'tramp-sh-file-name-handler) + auto-save-default) + (auto-save-mode 1))) +(add-hook 'find-file-hooks 'tramp-set-auto-save t) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'find-file-hooks 'tramp-set-auto-save))) + +(defun tramp-run-test (switch filename) + "Run `test' on the remote system, given a SWITCH and a FILENAME. +Returns the exit code of the `test' program." + (with-parsed-tramp-file-name filename nil + (tramp-send-command-and-check + v + (format + "%s %s %s" + (tramp-get-test-command v) + switch + (tramp-shell-quote-argument localname))))) + +(defun tramp-run-test2 (format-string file1 file2) + "Run `test'-like program on the remote system, given FILE1, FILE2. +FORMAT-STRING contains the program name, switches, and place holders. +Returns the exit code of the `test' program. Barfs if the methods, +hosts, or files, disagree." + (unless (tramp-equal-remote file1 file2) + (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil + (tramp-error + v 'file-error + "tramp-run-test2 only implemented for same method, user, host"))) + (with-parsed-tramp-file-name file1 v1 + (with-parsed-tramp-file-name file1 v2 + (tramp-send-command-and-check + v1 + (format format-string + (tramp-shell-quote-argument v1-localname) + (tramp-shell-quote-argument v2-localname)))))) + +(defun tramp-find-executable + (vec progname dirlist &optional ignore-tilde ignore-path) + "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST. +First arg VEC specifies the connection, PROGNAME is the program +to search for, and DIRLIST gives the list of directories to +search. If IGNORE-TILDE is non-nil, directory names starting +with `~' will be ignored. If IGNORE-PATH is non-nil, searches +only in DIRLIST. + +Returns the absolute file name of PROGNAME, if found, and nil otherwise. + +This function expects to be in the right *tramp* buffer." + (with-current-buffer (tramp-get-connection-buffer vec) + (let (result) + ;; Check whether the executable is in $PATH. "which(1)" does not + ;; report always a correct error code; therefore we check the + ;; number of words it returns. + (unless ignore-path + (tramp-send-command vec (format "which \\%s | wc -w" progname)) + (goto-char (point-min)) + (if (looking-at "^\\s-*1$") + (setq result (concat "\\" progname)))) + (unless result + (when ignore-tilde + ;; Remove all ~/foo directories from dirlist. In XEmacs, + ;; `remove' is in CL, and we want to avoid CL dependencies. + (let (newdl d) + (while dirlist + (setq d (car dirlist)) + (setq dirlist (cdr dirlist)) + (unless (char-equal ?~ (aref d 0)) + (setq newdl (cons d newdl)))) + (setq dirlist (nreverse newdl)))) + (tramp-send-command + vec + (format (concat "while read d; " + "do if test -x $d/%s -a -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'EOF'\n" + "%s\nEOF") + progname progname progname (mapconcat 'identity dirlist "\n"))) + (goto-char (point-max)) + (when (search-backward "tramp_executable " nil t) + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq result (buffer-substring + (point) (tramp-compat-line-end-position))))) + result))) + +(defun tramp-set-remote-path (vec) + "Sets the remote environment PATH to existing directories. +I.e., for each directory in `tramp-remote-path', it is tested +whether it exists and if so, it is added to the environment +variable PATH." + (tramp-message vec 5 (format "Setting $PATH environment variable")) + (tramp-send-command + vec (format "PATH=%s; export PATH" + (mapconcat 'identity (tramp-get-remote-path vec) ":")))) + +;; ------------------------------------------------------------ +;; -- Communication with external shell -- +;; ------------------------------------------------------------ + +(defun tramp-find-file-exists-command (vec) + "Find a command on the remote host for checking if a file exists. +Here, we are looking for a command which has zero exit status if the +file exists and nonzero exit status otherwise." + (let ((existing "/") + (nonexisting + (tramp-shell-quote-argument "/ this file does not exist ")) + result) + ;; The algorithm is as follows: we try a list of several commands. + ;; For each command, we first run `$cmd /' -- this should return + ;; true, as the root directory always exists. And then we run + ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed + ;; does not exist. This should return false. We use the first + ;; command we find that seems to work. + ;; The list of commands to try is as follows: + ;; `ls -d' This works on most systems, but NetBSD 1.4 + ;; has a bug: `ls' always returns zero exit + ;; status, even for files which don't exist. + ;; `test -e' Some Bourne shells have a `test' builtin + ;; which does not know the `-e' option. + ;; `/bin/test -e' For those, the `test' binary on disk normally + ;; provides the option. Alas, the binary + ;; is sometimes `/bin/test' and sometimes it's + ;; `/usr/bin/test'. + ;; `/usr/bin/test -e' In case `/bin/test' does not exist. + (unless (or + (and (setq result (format "%s -e" (tramp-get-test-command vec))) + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result "/bin/test -e") + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result "/usr/bin/test -e") + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result (format "%s -d" (tramp-get-ls-command vec))) + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting))))) + (tramp-error + vec 'file-error "Couldn't find command to check if file exists")) + result)) + +(defun tramp-open-shell (vec shell) + "Opens shell SHELL." + (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell) + ;; Find arguments for this shell. + (let ((tramp-end-of-output tramp-initial-end-of-output) + (alist tramp-sh-extra-args) + item extra-args) + (while (and alist (null extra-args)) + (setq item (pop alist)) + (when (string-match (car item) shell) + (setq extra-args (cdr item)))) + (when extra-args (setq shell (concat shell " " extra-args))) + (tramp-send-command + vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s" + (shell-quote-argument tramp-end-of-output) shell) + t)) + ;; Setting prompts. + (tramp-send-command + vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) + (tramp-send-command vec "PS2=''" t) + (tramp-send-command vec "PS3=''" t) + (tramp-send-command vec "PROMPT_COMMAND=''" t))) + +(defun tramp-find-shell (vec) + "Opens a shell on the remote host which groks tilde expansion." + (unless (tramp-get-connection-property vec "remote-shell" nil) + (let (shell) + (with-current-buffer (tramp-get-buffer vec) + (tramp-send-command vec "echo ~root" t) + (cond + ((or (string-match "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris is buggy. + (string-equal (tramp-get-connection-property vec "uname" "") + "SunOS 5.11")) + (setq shell + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t))) + (unless shell + (tramp-error + vec 'file-error + "Couldn't find a shell which groks tilde expansion")) + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)) + + (t (tramp-message + vec 5 "Remote `%s' groks tilde expansion, good" + (tramp-set-connection-property + vec "remote-shell" + (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-remote-sh))))))))) + +;; Utility functions. + +(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args) + "Wait for shell prompt and barf if none appears. +Looks at process PROC to see if a shell prompt appears in TIMEOUT +seconds. If not, it produces an error message with the given ERROR-ARGS." + (unless + (tramp-wait-for-regexp + proc timeout + (format + "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) + (apply 'tramp-error-with-buffer nil proc 'file-error error-args))) + +(defun tramp-open-connection-setup-interactive-shell (proc vec) + "Set up an interactive shell. +Mainly sets the prompt and the echo correctly. PROC is the shell +process to set up. VEC specifies the connection." + (let ((tramp-end-of-output tramp-initial-end-of-output)) + ;; It is useful to set the prompt in the following command because + ;; some people have a setting for $PS1 which /bin/sh doesn't know + ;; about and thus /bin/sh will display a strange prompt. For + ;; example, if $PS1 has "${CWD}" in the value, then ksh will + ;; display the current working directory but /bin/sh will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. Daniel Pittman reports that the unusual positioning of + ;; the single quotes makes it work under `rc', too. We also unset + ;; the variable $ENV because that is read by some sh + ;; implementations (eg, bash when called as sh) on startup; this + ;; way, we avoid the startup file clobbering $PS1. $PROMP_COMMAND + ;; is another way to set the prompt in /bin/bash, it must be + ;; discarded as well. + (tramp-open-shell + vec + (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh)) + + ;; Disable echo. + (tramp-message vec 5 "Setting up remote shell environment") + (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) + ;; Check whether the echo has really been disabled. Some + ;; implementations, like busybox of embedded GNU/Linux, don't + ;; support disabling. + (tramp-send-command vec "echo foo" t) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (when (looking-at "echo foo") + (tramp-set-connection-property proc "remote-echo" t) + (tramp-message vec 5 "Remote echo still on. Ok.") + ;; Make sure backspaces and their echo are enabled and no line + ;; width magic interferes with them. + (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) + + (tramp-message vec 5 "Setting shell prompt") + (tramp-send-command + vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) + (tramp-send-command vec "PS2=''" t) + (tramp-send-command vec "PS3=''" t) + (tramp-send-command vec "PROMPT_COMMAND=''" t) + + ;; Try to set up the coding system correctly. + ;; CCC this can't be the right way to do it. Hm. + (tramp-message vec 5 "Determining coding system") + (tramp-send-command vec "echo foo ; echo bar" t) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (if (featurep 'mule) + ;; Use MULE to select the right EOL convention for communicating + ;; with the process. + (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc) + (cons 'undecided 'undecided))) + cs-decode cs-encode) + (when (symbolp cs) (setq cs (cons cs cs))) + (setq cs-decode (car cs)) + (setq cs-encode (cdr cs)) + (unless cs-decode (setq cs-decode 'undecided)) + (unless cs-encode (setq cs-encode 'undecided)) + (setq cs-encode (tramp-coding-system-change-eol-conversion + cs-encode 'unix)) + (when (search-forward "\r" nil t) + (setq cs-decode (tramp-coding-system-change-eol-conversion + cs-decode 'dos))) + (tramp-compat-funcall + 'set-buffer-process-coding-system cs-decode cs-encode) + (tramp-message + vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode)) + ;; Look for ^M and do something useful if found. + (when (search-forward "\r" nil t) + ;; We have found a ^M but cannot frob the process coding system + ;; because we're running on a non-MULE Emacs. Let's try + ;; stty, instead. + (tramp-send-command vec "stty -onlcr" t)))) + ;; Dump stty settings in the traces. + (when (>= tramp-verbose 9) + (tramp-send-command vec "stty -a" t)) + (tramp-send-command vec "set +o vi +o emacs" t) + + ;; Check whether the output of "uname -sr" has been changed. If + ;; yes, this is a strong indication that we must expire all + ;; connection properties. We start again with + ;; `tramp-maybe-open-connection', it will be catched there. + (tramp-message vec 5 "Checking system information") + (let ((old-uname (tramp-get-connection-property vec "uname" nil)) + (new-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) + (with-current-buffer (tramp-get-debug-buffer vec) + ;; Keep the debug buffer. + (rename-buffer + (generate-new-buffer-name tramp-temp-buffer-name) 'unique) + (tramp-compat-funcall 'tramp-cleanup-connection vec) + (if (= (point-min) (point-max)) + (kill-buffer nil) + (rename-buffer (tramp-debug-buffer-name vec) 'unique)) + ;; We call `tramp-get-buffer' in order to keep the debug buffer. + (tramp-get-buffer vec) + (tramp-message + vec 3 + "Connection reset, because remote host changed from `%s' to `%s'" + old-uname new-uname) + (throw 'uname-changed (tramp-maybe-open-connection vec))))) + + ;; Check whether the remote host suffers from buggy + ;; `send-process-string'. This is known for FreeBSD (see comment in + ;; `send_process', file process.c). I've tested sending 624 bytes + ;; successfully, sending 625 bytes failed. Emacs makes a hack when + ;; this host type is detected locally. It cannot handle remote + ;; hosts, though. + (with-connection-property proc "chunksize" + (cond + ((and (integerp tramp-chunksize) (> tramp-chunksize 0)) + tramp-chunksize) + (t + (tramp-message + vec 5 "Checking remote host type for `send-process-string' bug") + (if (string-match + "^FreeBSD" (tramp-get-connection-property vec "uname" "")) + 500 0)))) + + ;; Set remote PATH variable. + (tramp-set-remote-path vec) + + ;; Search for a good shell before searching for a command which + ;; checks if a file exists. This is done because Tramp wants to use + ;; "test foo; echo $?" to check if various conditions hold, and + ;; there are buggy /bin/sh implementations which don't execute the + ;; "echo $?" part if the "test" part has an error. In particular, + ;; the OpenSolaris /bin/sh is a problem. There are also other + ;; problems with /bin/sh of OpenSolaris, like redirection of stderr + ;; in function declarations, or changing HISTFILE in place. + ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when + ;; detected. + (tramp-find-shell vec) + + ;; Disable unexpected output. + (tramp-send-command vec "mesg n; biff n" t) + + ;; IRIX64 bash expands "!" even when in single quotes. This + ;; destroys our shell functions, we must disable it. See + ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. + (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" "")) + (tramp-send-command vec "set +H" t)) + + ;; Set `remote-tty' process property. + (ignore-errors + (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\""))) + (unless (zerop (length tty)) + (tramp-compat-process-put proc 'remote-tty tty)))) + + ;; Set the environment. + (tramp-message vec 5 "Setting default environment") + + (let ((env (copy-sequence tramp-remote-process-environment)) + unset item) + (while env + (setq item (tramp-compat-split-string (car env) "=")) + (setcdr item (mapconcat 'identity (cdr item) "=")) + (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) + (tramp-send-command + vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t) + (push (car item) unset)) + (setq env (cdr env))) + (when unset + (tramp-send-command + vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) + +;; CCC: We should either implement a Perl version of base64 encoding +;; and decoding. Then we just use that in the last item. The other +;; alternative is to use the Perl version of UU encoding. But then +;; we need a Lisp version of uuencode. +;; +;; Old text from documentation of tramp-methods: +;; Using a uuencode/uudecode inline method is discouraged, please use one +;; of the base64 methods instead since base64 encoding is much more +;; reliable and the commands are more standardized between the different +;; Unix versions. But if you can't use base64 for some reason, please +;; note that the default uudecode command does not work well for some +;; Unices, in particular AIX and Irix. For AIX, you might want to use +;; the following command for uudecode: +;; +;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1 +;; +;; For Irix, no solution is known yet. + +(autoload 'uudecode-decode-region "uudecode") + +(defconst tramp-local-coding-commands + '((b64 base64-encode-region base64-decode-region) + (uu tramp-uuencode-region uudecode-decode-region) + (pack + "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" + "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) + "List of local coding commands for inline transfer. +Each item is a list that looks like this: + +\(FORMAT ENCODING DECODING\) + +FORMAT is symbol describing the encoding/decoding format. It can be +`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. + +ENCODING and DECODING can be strings, giving commands, or symbols, +giving functions. If they are strings, then they can contain +the \"%s\" format specifier. If that specifier is present, the input +filename will be put into the command line at that spot. If the +specifier is not present, the input should be read from standard +input. + +If they are functions, they will be called with two arguments, start +and end of region, and are expected to replace the region contents +with the encoded or decoded results, respectively.") + +(defconst tramp-remote-coding-commands + '((b64 "base64" "base64 -d") + (b64 "mimencode -b" "mimencode -u -b") + (b64 "mmencode -b" "mmencode -u -b") + (b64 "recode data..base64" "recode base64..data") + (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) + (b64 tramp-perl-encode tramp-perl-decode) + (uu "uuencode xxx" "uudecode -o /dev/stdout") + (uu "uuencode xxx" "uudecode -o -") + (uu "uuencode xxx" "uudecode -p") + (uu "uuencode xxx" tramp-uudecode) + (pack + "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" + "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) + "List of remote coding commands for inline transfer. +Each item is a list that looks like this: + +\(FORMAT ENCODING DECODING\) + +FORMAT is symbol describing the encoding/decoding format. It can be +`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. + +ENCODING and DECODING can be strings, giving commands, or symbols, +giving variables. If they are strings, then they can contain +the \"%s\" format specifier. If that specifier is present, the input +filename will be put into the command line at that spot. If the +specifier is not present, the input should be read from standard +input. + +If they are variables, this variable is a string containing a Perl +implementation for this functionality. This Perl program will be transferred +to the remote host, and it is available as shell function with the same name.") + +(defun tramp-find-inline-encoding (vec) + "Find an inline transfer encoding that works. +Goes through the list `tramp-local-coding-commands' and +`tramp-remote-coding-commands'." + (save-excursion + (let ((local-commands tramp-local-coding-commands) + (magic "xyzzy") + loc-enc loc-dec rem-enc rem-dec litem ritem found) + (while (and local-commands (not found)) + (setq litem (pop local-commands)) + (catch 'wont-work-local + (let ((format (nth 0 litem)) + (remote-commands tramp-remote-coding-commands)) + (setq loc-enc (nth 1 litem)) + (setq loc-dec (nth 2 litem)) + ;; If the local encoder or decoder is a string, the + ;; corresponding command has to work locally. + (if (not (stringp loc-enc)) + (tramp-message + vec 5 "Checking local encoding function `%s'" loc-enc) + (tramp-message + vec 5 "Checking local encoding command `%s' for sanity" loc-enc) + (unless (zerop (tramp-call-local-coding-command + loc-enc nil nil)) + (throw 'wont-work-local nil))) + (if (not (stringp loc-dec)) + (tramp-message + vec 5 "Checking local decoding function `%s'" loc-dec) + (tramp-message + vec 5 "Checking local decoding command `%s' for sanity" loc-dec) + (unless (zerop (tramp-call-local-coding-command + loc-dec nil nil)) + (throw 'wont-work-local nil))) + ;; Search for remote coding commands with the same format + (while (and remote-commands (not found)) + (setq ritem (pop remote-commands)) + (catch 'wont-work-remote + (when (equal format (nth 0 ritem)) + (setq rem-enc (nth 1 ritem)) + (setq rem-dec (nth 2 ritem)) + ;; Check if remote encoding and decoding commands can be + ;; called remotely with null input and output. This makes + ;; sure there are no syntax errors and the command is really + ;; found. Note that we do not redirect stdout to /dev/null, + ;; for two reasons: when checking the decoding command, we + ;; actually check the output it gives. And also, when + ;; redirecting "mimencode" output to /dev/null, then as root + ;; it might change the permissions of /dev/null! + (when (not (stringp rem-enc)) + (let ((name (symbol-name rem-enc))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (setq rem-enc name))) + (tramp-message + vec 5 + "Checking remote encoding command `%s' for sanity" rem-enc) + (unless (tramp-send-command-and-check + vec (format "%s </dev/null" rem-enc) t) + (throw 'wont-work-remote nil)) + + (when (not (stringp rem-dec)) + (let ((name (symbol-name rem-dec))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value rem-dec) name) + (setq rem-dec name))) + (tramp-message + vec 5 + "Checking remote decoding command `%s' for sanity" rem-dec) + (unless (tramp-send-command-and-check + vec + (format "echo %s | %s | %s" magic rem-enc rem-dec) + t) + (throw 'wont-work-remote nil)) + + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (unless (looking-at (regexp-quote magic)) + (throw 'wont-work-remote nil))) + + ;; `rem-enc' and `rem-dec' could be a string meanwhile. + (setq rem-enc (nth 1 ritem)) + (setq rem-dec (nth 2 ritem)) + (setq found t))))))) + + ;; Did we find something? + (unless found + (tramp-error + vec 'file-error "Couldn't find an inline transfer encoding")) + + ;; Set connection properties. + (tramp-message vec 5 "Using local encoding `%s'" loc-enc) + (tramp-set-connection-property vec "local-encoding" loc-enc) + (tramp-message vec 5 "Using local decoding `%s'" loc-dec) + (tramp-set-connection-property vec "local-decoding" loc-dec) + (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) + (tramp-set-connection-property vec "remote-encoding" rem-enc) + (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) + (tramp-set-connection-property vec "remote-decoding" rem-dec)))) + +(defun tramp-call-local-coding-command (cmd input output) + "Call the local encoding or decoding command. +If CMD contains \"%s\", provide input file INPUT there in command. +Otherwise, INPUT is passed via standard input. +INPUT can also be nil which means `/dev/null'. +OUTPUT can be a string (which specifies a filename), or t (which +means standard output and thus the current buffer), or nil (which +means discard it)." + (tramp-compat-call-process + tramp-encoding-shell + (when (and input (not (string-match "%s" cmd))) input) + (if (eq output t) t nil) + nil + tramp-encoding-command-switch + (concat + (if (string-match "%s" cmd) (format cmd input) cmd) + (if (stringp output) (concat "> " output) "")))) + +(defconst tramp-inline-compress-commands + '(("gzip" "gzip -d") + ("bzip2" "bzip2 -d") + ("compress" "compress -d")) + "List of compress and decompress commands for inline transfer. +Each item is a list that looks like this: + +\(COMPRESS DECOMPRESS\) + +COMPRESS or DECOMPRESS are strings with the respective commands.") + +(defun tramp-find-inline-compress (vec) + "Find an inline transfer compress command that works. +Goes through the list `tramp-inline-compress-commands'." + (save-excursion + (let ((commands tramp-inline-compress-commands) + (magic "xyzzy") + item compress decompress + found) + (while (and commands (not found)) + (catch 'next + (setq item (pop commands) + compress (nth 0 item) + decompress (nth 1 item)) + (tramp-message + vec 5 + "Checking local compress command `%s', `%s' for sanity" + compress decompress) + (unless (zerop (tramp-call-local-coding-command + (format "echo %s | %s | %s" + magic compress decompress) nil nil)) + (throw 'next nil)) + (tramp-message + vec 5 + "Checking remote compress command `%s', `%s' for sanity" + compress decompress) + (unless (tramp-send-command-and-check + vec (format "echo %s | %s | %s" magic compress decompress) t) + (throw 'next nil)) + (setq found t))) + + ;; Did we find something? + (if found + (progn + ;; Set connection properties. + (tramp-message + vec 5 "Using inline transfer compress command `%s'" compress) + (tramp-set-connection-property vec "inline-compress" compress) + (tramp-message + vec 5 "Using inline transfer decompress command `%s'" decompress) + (tramp-set-connection-property vec "inline-decompress" decompress)) + + (tramp-set-connection-property vec "inline-compress" nil) + (tramp-set-connection-property vec "inline-decompress" nil) + (tramp-message + vec 2 "Couldn't find an inline transfer compress command"))))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'. +Gateway hops are already opened." + (let ((target-alist `(,vec)) + (choices tramp-default-proxies-alist) + item proxy) + + ;; Look for proxy hosts to be passed. + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item))) + (when (and + ;; host + (string-match (or (eval (nth 0 item)) "") + (or (tramp-file-name-host (car target-alist)) "")) + ;; user + (string-match (or (eval (nth 1 item)) "") + (or (tramp-file-name-user (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (add-to-list 'target-alist l) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Handle gateways. + (when (string-match + (format + "^\\(%s\\|%s\\)$" tramp-gw-tunnel-method tramp-gw-socks-method) + (tramp-file-name-method (car target-alist))) + (let ((gw (pop target-alist)) + (hop (pop target-alist))) + ;; Is the method prepared for gateways? + (unless (tramp-get-method-parameter + (tramp-file-name-method hop) 'tramp-default-port) + (tramp-error + vec 'file-error + "Method `%s' is not supported for gateway access." + (tramp-file-name-method hop))) + ;; Add default port if needed. + (unless + (string-match + tramp-host-with-port-regexp (tramp-file-name-host hop)) + (aset hop 2 + (concat + (tramp-file-name-host hop) tramp-prefix-port-format + (number-to-string + (tramp-get-method-parameter + (tramp-file-name-method hop) 'tramp-default-port))))) + ;; Open the gateway connection. + (add-to-list + 'target-alist + (vector + (tramp-file-name-method hop) (tramp-file-name-user hop) + (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil)) + ;; For the password prompt, we need the correct values. + ;; Therefore, we must remember the gateway vector. But we + ;; cannot do it as connection property, because it shouldn't + ;; be persistent. And we have no started process yet either. + (tramp-set-file-property (car target-alist) "" "gateway" hop))) + + ;; Foreign and out-of-band methods are not supported for multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while choices + (setq item (pop choices)) + (when + (or + (not + (tramp-get-method-parameter + (tramp-file-name-method item) 'tramp-login-program)) + (tramp-get-method-parameter + (tramp-file-name-method item) 'tramp-copy-program)) + (tramp-error + vec 'file-error + "Method `%s' is not supported for multi-hops." + (tramp-file-name-method item))))) + + ;; In case the host name is not used for the remote shell + ;; command, the user could be misguided by applying a random + ;; hostname. + (let* ((v (car target-alist)) + (method (tramp-file-name-method v)) + (host (tramp-file-name-host v))) + (unless + (or + ;; There are multi-hops. + (cdr target-alist) + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter method 'tramp-login-args)) + ;; The host is local. We cannot use `tramp-local-host-p' + ;; here, because it opens a connection as well. + (string-match tramp-local-host-regexp host)) + (tramp-error + v 'file-error + "Host `%s' looks like a remote host, `%s' can only use the local host" + host method))) + + ;; Result. + target-alist)) + +(defun tramp-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + (catch 'uname-changed + (let ((p (tramp-get-connection-process vec)) + (process-name (tramp-get-connection-property vec "process-name" nil)) + (process-environment (copy-sequence process-environment))) + + ;; If too much time has passed since last command was sent, look + ;; whether process is still alive. If it isn't, kill it. When + ;; using ssh, it can sometimes happen that the remote end has + ;; hung up but the local ssh client doesn't recognize this until + ;; it tries to send some data to the remote end. So that's why + ;; we try to send a command from time to time, then look again + ;; whether the process is really alive. + (condition-case nil + (when (and (> (tramp-time-diff + (current-time) + (tramp-get-connection-property + p "last-cmd-time" '(0 0 0))) + 60) + p (processp p) (memq (process-status p) '(run open))) + (tramp-send-command vec "echo are you awake" t t) + (unless (and (memq (process-status p) '(run open)) + (tramp-wait-for-output p 10)) + ;; The error will be catched locally. + (tramp-error vec 'file-error "Awake did fail"))) + (file-error + (tramp-flush-connection-property vec) + (tramp-flush-connection-property p) + (delete-process p) + (setq p nil))) + + ;; New connection must be opened. + (unless (and p (processp p) (memq (process-status p) '(run open))) + + ;; We call `tramp-get-buffer' in order to get a debug buffer for + ;; messages from the beginning. + (tramp-get-buffer vec) + (with-progress-reporter + vec 3 + (if (zerop (length (tramp-file-name-user vec))) + (format "Opening connection for %s using %s" + (tramp-file-name-host vec) + (tramp-file-name-method vec)) + (format "Opening connection for %s@%s using %s" + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-file-name-method vec))) + + ;; Start new process. + (when (and p (processp p)) + (delete-process p)) + (setenv "TERM" tramp-terminal-type) + (setenv "LC_ALL" "C") + (setenv "PROMPT_COMMAND") + (setenv "PS1" tramp-initial-end-of-output) + (let* ((target-alist (tramp-compute-multi-hops vec)) + (process-connection-type tramp-process-connection-type) + (process-adaptive-read-buffering nil) + (coding-system-for-read nil) + ;; This must be done in order to avoid our file name handler. + (p (let ((default-directory + (tramp-compat-temporary-file-directory))) + (start-process + (or process-name (tramp-buffer-name vec)) + (tramp-get-connection-buffer vec) + tramp-encoding-shell)))) + + (tramp-message + vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + + ;; Check whether process is alive. + (tramp-set-process-query-on-exit-flag p nil) + (tramp-barf-if-no-shell-prompt + p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell) + + ;; Now do all the connections as specified. + (while target-alist + (let* ((hop (car target-alist)) + (l-method (tramp-file-name-method hop)) + (l-user (tramp-file-name-user hop)) + (l-host (tramp-file-name-host hop)) + (l-port nil) + (login-program + (tramp-get-method-parameter + l-method 'tramp-login-program)) + (login-args + (tramp-get-method-parameter l-method 'tramp-login-args)) + (async-args + (tramp-get-method-parameter l-method 'tramp-async-args)) + (gw-args + (tramp-get-method-parameter l-method 'tramp-gw-args)) + (gw (tramp-get-file-property hop "" "gateway" nil)) + (g-method (and gw (tramp-file-name-method gw))) + (g-user (and gw (tramp-file-name-user gw))) + (g-host (and gw (tramp-file-name-host gw))) + (command login-program) + ;; We don't create the temporary file. In fact, + ;; it is just a prefix for the ControlPath option + ;; of ssh; the real temporary file has another + ;; name, and it is created and protected by ssh. + ;; It is also removed by ssh, when the connection + ;; is closed. + (tmpfile + (tramp-set-connection-property + p "temp-file" + (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory))))) + spec) + + ;; Add arguments for asynchrononous processes. + (when (and process-name async-args) + (setq login-args (append async-args login-args))) + + ;; Add gateway arguments if necessary. + (when (and gw gw-args) + (setq login-args (append gw-args login-args))) + + ;; Check for port number. Until now, there's no need + ;; for handling like method, user, host. + (when (string-match tramp-host-with-port-regexp l-host) + (setq l-port (match-string 2 l-host) + l-host (match-string 1 l-host))) + + ;; Set variables for computing the prompt for reading + ;; password. They can also be derived from a gateway. + (setq tramp-current-method (or g-method l-method) + tramp-current-user (or g-user l-user) + tramp-current-host (or g-host l-host)) + + ;; Replace login-args place holders. + (setq + l-host (or l-host "") + l-user (or l-user "") + l-port (or l-port "") + spec (format-spec-make + ?h l-host ?u l-user ?p l-port ?t tmpfile) + command + (concat + ;; We do not want to see the trailing local prompt in + ;; `start-file-process'. + (unless (memq system-type '(windows-nt)) "exec ") + command " " + (mapconcat + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) (mapconcat 'identity x " "))) + login-args " ") + ;; Local shell could be a Windows COMSPEC. It + ;; doesn't know the ";" syntax, but we must exit + ;; always for `start-file-process'. "exec" does not + ;; work either. + (if (memq system-type '(windows-nt)) " && exit || exit"))) + + ;; Send the command. + (tramp-message vec 3 "Sending command `%s'" command) + (tramp-send-command vec command t t) + (tramp-process-actions p vec tramp-actions-before-shell 60) + (tramp-message + vec 3 "Found remote shell prompt on `%s'" l-host)) + ;; Next hop. + (setq target-alist (cdr target-alist))) + + ;; Make initial shell settings. + (tramp-open-connection-setup-interactive-shell p vec))))))) + +(defun tramp-send-command (vec command &optional neveropen nooutput) + "Send the COMMAND to connection VEC. +Erases temporary buffer before sending the command. If optional +arg NEVEROPEN is non-nil, never try to open the connection. This +is meant to be used from `tramp-maybe-open-connection' only. The +function waits for output unless NOOUTPUT is set." + (unless neveropen (tramp-maybe-open-connection vec)) + (let ((p (tramp-get-connection-process vec))) + (when (tramp-get-connection-property p "remote-echo" nil) + ;; We mark the command string that it can be erased in the output buffer. + (tramp-set-connection-property p "check-remote-echo" t) + (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) + (tramp-message vec 6 "%s" command) + (tramp-send-string vec command) + (unless nooutput (tramp-wait-for-output p)))) + +(defun tramp-wait-for-output (proc &optional timeout) + "Wait for output from remote command." + (unless (buffer-live-p (process-buffer proc)) + (delete-process proc) + (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) + (with-current-buffer (process-buffer proc) + (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might + ;; be leading escape sequences, which must be ignored. + (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output))) + ;; Sometimes, the commands do not return a newline but a + ;; null byte before the shell prompt, for example "git + ;; ls-files -c -z ...". + (regexp1 (format "\\(^\\|\000\\)%s" regexp)) + (found (tramp-wait-for-regexp proc timeout regexp1))) + (if found + (let (buffer-read-only) + ;; A simple-minded busybox has sent " ^H" sequences. + ;; Delete them. + (goto-char (point-min)) + (when (re-search-forward + "^\\(.\b\\)+$" (tramp-compat-line-end-position) t) + (forward-line 1) + (delete-region (point-min) (point))) + ;; Delete the prompt. + (goto-char (point-max)) + (re-search-backward regexp nil t) + (delete-region (point) (point-max))) + (if timeout + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found in %d secs]]" + tramp-end-of-output timeout) + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found]]" tramp-end-of-output))) + ;; Return value is whether end-of-output sentinel was found. + found))) + +(defun tramp-send-command-and-check + (vec command &optional subshell dont-suppress-err) + "Run COMMAND and check its exit status. +Sends `echo $?' along with the COMMAND for checking the exit status. If +COMMAND is nil, just sends `echo $?'. Returns the exit status found. + +If the optional argument SUBSHELL is non-nil, the command is +executed in a subshell, ie surrounded by parentheses. If +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." + (tramp-send-command + vec + (concat (if subshell "( " "") + command + (if command (if dont-suppress-err "; " " 2>/dev/null; ") "") + "echo tramp_exit_status $?" + (if subshell " )" ""))) + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-max)) + (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) + (tramp-error + vec 'file-error "Couldn't find exit status of `%s'" command)) + (skip-chars-forward "^ ") + (prog1 + (zerop (read (current-buffer))) + (let (buffer-read-only) + (delete-region (match-beginning 0) (point-max)))))) + +(defun tramp-barf-unless-okay (vec command fmt &rest args) + "Run COMMAND, check exit status, throw error if exit status not okay. +Similar to `tramp-send-command-and-check' but accepts two more arguments +FMT and ARGS which are passed to `error'." + (unless (tramp-send-command-and-check vec command) + (apply 'tramp-error vec 'file-error fmt args))) + +(defun tramp-send-command-and-read (vec command) + "Run COMMAND and return the output, which must be a Lisp expression. +In case there is no valid Lisp expression, it raises an error" + (tramp-barf-unless-okay vec command "`%s' returns with error" command) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Read the expression. + (goto-char (point-min)) + (condition-case nil + (prog1 (read (current-buffer)) + ;; Error handling. + (when (re-search-forward "\\S-" (tramp-compat-line-end-position) t) + (error nil))) + (error (tramp-error + vec 'file-error + "`%s' does not return a valid Lisp expression: `%s'" + command (buffer-string)))))) + +(defun tramp-mode-string-to-int (mode-string) + "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." + (let* (case-fold-search + (mode-chars (string-to-vector mode-string)) + (owner-read (aref mode-chars 1)) + (owner-write (aref mode-chars 2)) + (owner-execute-or-setid (aref mode-chars 3)) + (group-read (aref mode-chars 4)) + (group-write (aref mode-chars 5)) + (group-execute-or-setid (aref mode-chars 6)) + (other-read (aref mode-chars 7)) + (other-write (aref mode-chars 8)) + (other-execute-or-sticky (aref mode-chars 9))) + (save-match-data + (logior + (cond + ((char-equal owner-read ?r) (tramp-compat-octal-to-decimal "00400")) + ((char-equal owner-read ?-) 0) + (t (error "Second char `%c' must be one of `r-'" owner-read))) + (cond + ((char-equal owner-write ?w) (tramp-compat-octal-to-decimal "00200")) + ((char-equal owner-write ?-) 0) + (t (error "Third char `%c' must be one of `w-'" owner-write))) + (cond + ((char-equal owner-execute-or-setid ?x) + (tramp-compat-octal-to-decimal "00100")) + ((char-equal owner-execute-or-setid ?S) + (tramp-compat-octal-to-decimal "04000")) + ((char-equal owner-execute-or-setid ?s) + (tramp-compat-octal-to-decimal "04100")) + ((char-equal owner-execute-or-setid ?-) 0) + (t (error "Fourth char `%c' must be one of `xsS-'" + owner-execute-or-setid))) + (cond + ((char-equal group-read ?r) (tramp-compat-octal-to-decimal "00040")) + ((char-equal group-read ?-) 0) + (t (error "Fifth char `%c' must be one of `r-'" group-read))) + (cond + ((char-equal group-write ?w) (tramp-compat-octal-to-decimal "00020")) + ((char-equal group-write ?-) 0) + (t (error "Sixth char `%c' must be one of `w-'" group-write))) + (cond + ((char-equal group-execute-or-setid ?x) + (tramp-compat-octal-to-decimal "00010")) + ((char-equal group-execute-or-setid ?S) + (tramp-compat-octal-to-decimal "02000")) + ((char-equal group-execute-or-setid ?s) + (tramp-compat-octal-to-decimal "02010")) + ((char-equal group-execute-or-setid ?-) 0) + (t (error "Seventh char `%c' must be one of `xsS-'" + group-execute-or-setid))) + (cond + ((char-equal other-read ?r) + (tramp-compat-octal-to-decimal "00004")) + ((char-equal other-read ?-) 0) + (t (error "Eighth char `%c' must be one of `r-'" other-read))) + (cond + ((char-equal other-write ?w) (tramp-compat-octal-to-decimal "00002")) + ((char-equal other-write ?-) 0) + (t (error "Nineth char `%c' must be one of `w-'" other-write))) + (cond + ((char-equal other-execute-or-sticky ?x) + (tramp-compat-octal-to-decimal "00001")) + ((char-equal other-execute-or-sticky ?T) + (tramp-compat-octal-to-decimal "01000")) + ((char-equal other-execute-or-sticky ?t) + (tramp-compat-octal-to-decimal "01001")) + ((char-equal other-execute-or-sticky ?-) 0) + (t (error "Tenth char `%c' must be one of `xtT-'" + other-execute-or-sticky))))))) + +(defun tramp-convert-file-attributes (vec attr) + "Convert file-attributes ATTR generated by perl script, stat or ls. +Convert file mode bits to string and set virtual device number. +Return ATTR." + (when attr + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) + (list (floor (nth 4 attr) 65536) + (floor (mod (nth 4 attr) 65536))))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) + (list (floor (nth 5 attr) 65536) + (floor (mod (nth 5 attr) 65536))))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) + (list (floor (nth 6 attr) 65536) + (floor (mod (nth 6 attr) 65536))))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-match "^d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + (when (consp (car attr)) + (if (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr))) + (setcar attr (match-string 1 (caar attr))) + (setcar attr nil))) + ;; Set file's gid change bit. + (setcar (nthcdr 9 attr) + (if (numberp (nth 3 attr)) + (not (= (nth 3 attr) + (tramp-get-remote-gid vec 'integer))) + (not (string-equal + (nth 3 attr) + (tramp-get-remote-gid vec 'string))))) + ;; Convert inode. + (unless (listp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (cons (floor (nth 10 attr) 65536) + (floor (mod (nth 10 attr) 65536))) + ;; Inodes can be incredible huge. We must hide this. + (error (tramp-get-inode vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device vec)) + attr)) + +(defun tramp-check-cached-permissions (vec access) + "Check `file-attributes' caches for VEC. +Return t if according to the cache access type ACCESS is known to +be granted." + (let ((result nil) + (offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3)))) + (dolist (suffix '("string" "integer") result) + (setq + result + (or + result + (let ((file-attr + (tramp-get-file-property + vec (tramp-file-name-localname vec) + (concat "file-attributes-" suffix) nil)) + (remote-uid + (tramp-get-connection-property + vec (concat "uid-" suffix) nil)) + (remote-gid + (tramp-get-connection-property + vec (concat "gid-" suffix) nil))) + (and + file-attr + (or + ;; Not a symlink + (eq t (car file-attr)) + (null (car file-attr))) + (or + ;; World accessible. + (eq access (aref (nth 8 file-attr) (+ offset 6))) + ;; User accessible and owned by user. + (and + (eq access (aref (nth 8 file-attr) offset)) + (equal remote-uid (nth 2 file-attr))) + ;; Group accessible and owned by user's + ;; principal group. + (and + (eq access (aref (nth 8 file-attr) (+ offset 3))) + (equal remote-gid (nth 3 file-attr))))))))))) + +(defun tramp-file-mode-from-int (mode) + "Turn an integer representing a file mode into an ls(1)-like string." + (let ((type (cdr + (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) + (user (logand (lsh mode -6) 7)) + (group (logand (lsh mode -3) 7)) + (other (logand (lsh mode -0) 7)) + (suid (> (logand (lsh mode -9) 4) 0)) + (sgid (> (logand (lsh mode -9) 2) 0)) + (sticky (> (logand (lsh mode -9) 1) 0))) + (setq user (tramp-file-mode-permissions user suid "s")) + (setq group (tramp-file-mode-permissions group sgid "s")) + (setq other (tramp-file-mode-permissions other sticky "t")) + (concat type user group other))) + +(defun tramp-file-mode-permissions (perm suid suid-text) + "Convert a permission bitset into a string. +This is used internally by `tramp-file-mode-from-int'." + (let ((r (> (logand perm 4) 0)) + (w (> (logand perm 2) 0)) + (x (> (logand perm 1) 0))) + (concat (or (and r "r") "-") + (or (and w "w") "-") + (or (and suid x suid-text) ; suid, execute + (and suid (upcase suid-text)) ; suid, !execute + (and x "x") "-")))) ; !suid + +(defun tramp-shell-case-fold (string) + "Converts STRING to shell glob pattern which ignores case." + (mapconcat + (lambda (c) + (if (equal (downcase c) (upcase c)) + (vector c) + (format "[%c%c]" (downcase c) (upcase c)))) + string + "")) + +(defun tramp-make-copy-program-file-name (vec) + "Create a file name suitable to be passed to `rcp' and workalikes." + (let ((user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec)) + (localname (tramp-shell-quote-argument + (tramp-file-name-localname vec)))) + (if (not (zerop (length user))) + (format "%s@%s:%s" user host localname) + (format "%s:%s" host localname)))) + +(defun tramp-method-out-of-band-p (vec size) + "Return t if this is an out-of-band method, nil otherwise." + (and + ;; It shall be an out-of-band method. + (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) + ;; Either the file size is large enough, or (in rare cases) there + ;; does not exist a remote encoding. + (or (null tramp-copy-size-limit) + (> size tramp-copy-size-limit) + (null (tramp-get-inline-coding vec "remote-encoding" size))))) + +(defun tramp-local-host-p (vec) + "Return t if this points to the local host, nil otherwise." + ;; We cannot use `tramp-file-name-real-host'. A port is an + ;; indication for an ssh tunnel or alike. + (let ((host (tramp-file-name-host vec))) + (and + (stringp host) + (string-match tramp-local-host-regexp host) + ;; The method shall be applied to one of the shell file name + ;; handler. `tramp-local-host-p' is also called for "smb" and + ;; alike, where it must fail. + (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-login-program) + ;; The local temp directory must be writable for the other user. + (file-writable-p + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + host + (tramp-compat-temporary-file-directory))) + ;; On some systems, chown runs only for root. + (or (zerop (user-uid)) + (zerop (tramp-get-remote-uid vec 'integer)))))) + +;; Variables local to connection. + +(defun tramp-get-remote-path (vec) + (with-connection-property + ;; When `tramp-own-remote-path' is in `tramp-remote-path', we + ;; cache the result for the session only. Otherwise, the result + ;; is cached persistently. + (if (memq 'tramp-own-remote-path tramp-remote-path) + (tramp-get-connection-process vec) + vec) + "remote-path" + (let* ((remote-path (copy-tree tramp-remote-path)) + (elt1 (memq 'tramp-default-remote-path remote-path)) + (elt2 (memq 'tramp-own-remote-path remote-path)) + (default-remote-path + (when elt1 + (condition-case nil + (tramp-send-command-and-read + vec "echo \\\"`getconf PATH`\\\"") + ;; Default if "getconf" is not available. + (error + (tramp-message + vec 3 + "`getconf PATH' not successful, using default value \"%s\"." + "/bin:/usr/bin") + "/bin:/usr/bin")))) + (own-remote-path + (when elt2 + (condition-case nil + (tramp-send-command-and-read vec "echo \\\"$PATH\\\"") + ;; Default if "getconf" is not available. + (error + (tramp-message + vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.") + nil))))) + + ;; Replace place holder `tramp-default-remote-path'. + (when elt1 + (setcdr elt1 + (append + (tramp-compat-split-string default-remote-path ":") + (cdr elt1))) + (setq remote-path (delq 'tramp-default-remote-path remote-path))) + + ;; Replace place holder `tramp-own-remote-path'. + (when elt2 + (setcdr elt2 + (append + (tramp-compat-split-string own-remote-path ":") + (cdr elt2))) + (setq remote-path (delq 'tramp-own-remote-path remote-path))) + + ;; Remove double entries. + (setq elt1 remote-path) + (while (consp elt1) + (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) + (setcar elt2 nil)) + (setq elt1 (cdr elt1))) + + ;; Remove non-existing directories. + (delq + nil + (mapcar + (lambda (x) + (and + (stringp x) + (file-directory-p + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + x)) + x)) + remote-path))))) + +(defun tramp-get-remote-tmpdir (vec) + (with-connection-property vec "tmp-directory" + (let ((dir (tramp-shell-quote-argument "/tmp"))) + (if (and (tramp-send-command-and-check + vec (format "%s -d %s" (tramp-get-test-command vec) dir)) + (tramp-send-command-and-check + vec (format "%s -w %s" (tramp-get-test-command vec) dir))) + dir + (tramp-error vec 'file-error "Directory %s not accessible" dir))))) + +(defun tramp-make-tramp-temp-file (vec) + "Create a temporary file on the remote host identified by VEC. +Return the local name of the temporary file." + (let ((prefix + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-drop-volume-letter + (expand-file-name + tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + result) + (while (not result) + ;; `make-temp-file' would be the natural choice for + ;; implementation. But it calls `write-region' internally, + ;; which also needs a temporary file - we would end in an + ;; infinite loop. + (setq result (make-temp-name prefix)) + (if (file-exists-p result) + (setq result nil) + ;; This creates the file by side effect. + (set-file-times result) + (set-file-modes result (tramp-compat-octal-to-decimal "0700")))) + + ;; Return the local part. + (with-parsed-tramp-file-name result nil localname))) + +(defun tramp-get-ls-command (vec) + (with-connection-property vec "ls" + (tramp-message vec 5 "Finding a suitable `ls' command") + (or + (catch 'ls-found + (dolist (cmd '("ls" "gnuls" "gls")) + (let ((dl (tramp-get-remote-path vec)) + result) + (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) + ;; Check parameters. On busybox, "ls" output coloring is + ;; enabled by default sometimes. So we try to disable it + ;; when possible. $LS_COLORING is not supported there. + ;; Some "ls" versions are sensible wrt the order of + ;; arguments, they fail when "-al" is after the + ;; "--color=never" argument (for example on FreeBSD). + (when (tramp-send-command-and-check + vec (format "%s -lnd /" result)) + (when (tramp-send-command-and-check + vec (format + "%s --color=never -al /dev/null" result)) + (setq result (concat result " --color=never"))) + (throw 'ls-found result)) + (setq dl (cdr dl)))))) + (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) + +(defun tramp-get-ls-command-with-dired (vec) + (save-match-data + (with-connection-property vec "ls-dired" + (tramp-message vec 5 "Checking, whether `ls --dired' works") + ;; Some "ls" versions are sensible wrt the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). + (tramp-send-command-and-check + vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) + +(defun tramp-get-test-command (vec) + (with-connection-property vec "test" + (tramp-message vec 5 "Finding a suitable `test' command") + (if (tramp-send-command-and-check vec "test 0") + "test" + (tramp-find-executable vec "test" (tramp-get-remote-path vec))))) + +(defun tramp-get-test-nt-command (vec) + ;; Does `test A -nt B' work? Use abominable `find' construct if it + ;; doesn't. BSD/OS 4.0 wants the parentheses around the command, + ;; for otherwise the shell crashes. + (with-connection-property vec "test-nt" + (or + (progn + (tramp-send-command + vec (format "( %s / -nt / )" (tramp-get-test-command vec))) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (when (looking-at (regexp-quote tramp-end-of-output)) + (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) + (progn + (tramp-send-command + vec + (format + "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}" + (tramp-get-test-command vec))) + "tramp_test_nt %s %s")))) + +(defun tramp-get-file-exists-command (vec) + (with-connection-property vec "file-exists" + (tramp-message vec 5 "Finding command to check if file exists") + (tramp-find-file-exists-command vec))) + +(defun tramp-get-remote-ln (vec) + (with-connection-property vec "ln" + (tramp-message vec 5 "Finding a suitable `ln' command") + (tramp-find-executable vec "ln" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-perl (vec) + (with-connection-property vec "perl" + (tramp-message vec 5 "Finding a suitable `perl' command") + (let ((result + (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec)) + (tramp-find-executable + vec "perl" (tramp-get-remote-path vec))))) + ;; We must check also for some Perl modules. + (when result + (with-connection-property vec "perl-file-spec" + (tramp-send-command-and-check + vec (format "%s -e 'use File::Spec;'" result))) + (with-connection-property vec "perl-cwd-realpath" + (tramp-send-command-and-check + vec (format "%s -e 'use Cwd \"realpath\";'" result)))) + result))) + +(defun tramp-get-remote-stat (vec) + (with-connection-property vec "stat" + (tramp-message vec 5 "Finding a suitable `stat' command") + (let ((result (tramp-find-executable + vec "stat" (tramp-get-remote-path vec))) + tmp) + ;; Check whether stat(1) returns usable syntax. %s does not + ;; work on older AIX systems. + (when result + (setq tmp + ;; We don't want to display an error message. + (tramp-compat-with-temp-message (or (current-message) "") + (ignore-errors + (tramp-send-command-and-read + vec (format "%s -c '(\"%%N\" %%s)' /" result))))) + (unless (and (listp tmp) (stringp (car tmp)) + (string-match "^./.$" (car tmp)) + (integerp (cadr tmp))) + (setq result nil))) + result))) + +(defun tramp-get-remote-readlink (vec) + (with-connection-property vec "readlink" + (tramp-message vec 5 "Finding a suitable `readlink' command") + (let ((result (tramp-find-executable + vec "readlink" (tramp-get-remote-path vec)))) + (when (and result + ;; We don't want to display an error message. + (tramp-compat-with-temp-message (or (current-message) "") + (ignore-errors + (tramp-send-command-and-check + vec (format "%s --canonicalize-missing /" result))))) + result)))) + +(defun tramp-get-remote-trash (vec) + (with-connection-property vec "trash" + (tramp-message vec 5 "Finding a suitable `trash' command") + (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-id (vec) + (with-connection-property vec "id" + (tramp-message vec 5 "Finding POSIX `id' command") + (or + (catch 'id-found + (let ((dl (tramp-get-remote-path vec)) + result) + (while (and dl (setq result (tramp-find-executable vec "id" dl t t))) + ;; Check POSIX parameter. + (when (tramp-send-command-and-check vec (format "%s -u" result)) + (throw 'id-found result)) + (setq dl (cdr dl))))) + (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))) + +(defun tramp-get-remote-uid (vec id-format) + (with-connection-property vec (format "uid-%s" id-format) + (let ((res (tramp-send-command-and-read + vec + (format "%s -u%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) + ;; The command might not always return a number. + (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + +(defun tramp-get-remote-gid (vec id-format) + (with-connection-property vec (format "gid-%s" id-format) + (let ((res (tramp-send-command-and-read + vec + (format "%s -g%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) + ;; The command might not always return a number. + (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + +(defun tramp-get-local-uid (id-format) + (if (equal id-format 'integer) (user-uid) (user-login-name))) + +(defun tramp-get-local-gid (id-format) + (nth 3 (tramp-compat-file-attributes "~/" id-format))) + +;; Some predefined connection properties. +(defun tramp-get-inline-compress (vec prop size) + "Return the compress command related to PROP. +PROP is either `inline-compress' or `inline-decompress'. SIZE is +the length of the file to be compressed. + +If no corresponding command is found, nil is returned." + (when (and (integerp tramp-inline-compress-start-size) + (> size tramp-inline-compress-start-size)) + (with-connection-property vec prop + (tramp-find-inline-compress vec) + (tramp-get-connection-property vec prop nil)))) + +(defun tramp-get-inline-coding (vec prop size) + "Return the coding command related to PROP. +PROP is either `remote-encoding', `remode-decoding', +`local-encoding' or `local-decoding'. + +SIZE is the length of the file to be coded. Depending on SIZE, +compression might be applied. + +If no corresponding command is found, nil is returned. +Otherwise, either a string is returned which contains a `%s' mark +to be used for the respective input or output file; or a Lisp +function cell is returned to be applied on a buffer." + (let ((coding + (with-connection-property vec prop + (tramp-find-inline-encoding vec) + (tramp-get-connection-property vec prop nil))) + (prop1 (if (string-match "encoding" prop) + "inline-compress" "inline-decompress")) + compress) + ;; The connection property might have been cached. So we must send + ;; the script to the remote side - maybe. + (when (and coding (symbolp coding) (string-match "remote" prop)) + (let ((name (symbol-name coding))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value coding) name) + (setq coding name))) + (when coding + ;; Check for the `compress' command. + (setq compress (tramp-get-inline-compress vec prop1 size)) + ;; Return the value. + (cond + ((and compress (symbolp coding)) + (if (string-match "decompress" prop1) + `(lambda (beg end) + (,coding beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region (point-min) (point-max) + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress))))) + `(lambda (beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region beg end + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress)))) + (,coding (point-min) (point-max))))) + ((symbolp coding) + coding) + ((and compress (string-match "decoding" prop)) + (format "(%s | %s >%%s)" coding compress)) + (compress + (format "(%s <%%s | %s)" compress coding)) + ((string-match "decoding" prop) + (format "%s >%%s" coding)) + (t + (format "%s <%%s" coding)))))) + +;;; Integration of eshell.el: + +(eval-when-compile + (defvar eshell-path-env)) + +;; eshell.el keeps the path in `eshell-path-env'. We must change it +;; when `default-directory' points to another host. +(defun tramp-eshell-directory-change () + "Set `eshell-path-env' to $PATH of the host related to `default-directory'." + (setq eshell-path-env + (if (file-remote-p default-directory) + (with-parsed-tramp-file-name default-directory nil + (mapconcat + 'identity + (tramp-get-remote-path v) + ":")) + (getenv "PATH")))) + +(eval-after-load "esh-util" + '(progn + (tramp-eshell-directory-change) + (add-hook 'eshell-directory-change-hook + 'tramp-eshell-directory-change) + (add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'eshell-directory-change-hook + 'tramp-eshell-directory-change))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sh 'force))) + +(provide 'tramp-sh) + +;;; TODO: + +;; * Don't use globbing for directories with many files, as this is +;; likely to produce long command lines, and some shells choke on +;; long command lines. +;; * Make it work for different encodings, and for different file name +;; encodings, too. (Daniel Pittman) +;; * Don't search for perl5 and perl. Instead, only search for perl and +;; then look if it's the right version (with `perl -v'). +;; * When editing a remote CVS controlled file as a different user, VC +;; gets confused about the file locking status. Try to find out why +;; the workaround doesn't work. +;; * Allow out-of-band methods as _last_ multi-hop. Open a connection +;; until the last but one hop via `start-file-process'. Apply it +;; also for ftp and smb. +;; * WIBNI if we had a command "trampclient"? If I was editing in +;; some shell with root priviledges, it would be nice if I could +;; just call +;; trampclient filename.c +;; as an editor, and the _current_ shell would connect to an Emacs +;; server and would be used in an existing non-priviledged Emacs +;; session for doing the editing in question. +;; That way, I need not tell Emacs my password again and be afraid +;; that it makes it into core dumps or other ugly stuff (I had Emacs +;; once display a just typed password in the context of a keyboard +;; sequence prompt for a question immediately following in a shell +;; script run within Emacs -- nasty). +;; And if I have some ssh session running to a different computer, +;; having the possibility of passing a local file there to a local +;; Emacs session (in case I can arrange for a connection back) would +;; be nice. +;; Likely the corresponding Tramp server should not allow the +;; equivalent of the emacsclient -eval option in order to make this +;; reasonably unproblematic. And maybe trampclient should have some +;; way of passing credentials, like by using an SSL socket or +;; something. (David Kastrup) +;; * Reconnect directly to a compliant shell without first going +;; through the user's default shell. (Pete Forman) +;; * How can I interrupt the remote process with a signal +;; (interrupt-process seems not to work)? (Markus Triska) +;; * Avoid the local shell entirely for starting remote processes. If +;; so, I think even a signal, when delivered directly to the local +;; SSH instance, would correctly be propagated to the remote process +;; automatically; possibly SSH would have to be started with +;; "-t". (Markus Triska) +;; * It makes me wonder if tramp couldn't fall back to ssh when scp +;; isn't on the remote host. (Mark A. Hershberger) +;; * Use lsh instead of ssh. (Alfred M. Szmidt) +;; * Optimize out-of-band copying, when both methods are scp-like (not +;; rsync). +;; * Keep a second connection open for out-of-band methods like scp or +;; rsync. +;; * Try telnet+curl as new method. It might be useful for busybox, +;; without built-in uuencode/uudecode. + +;;; tramp-sh.el ends here
--- a/lisp/net/tramp-smb.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-smb.el Wed Sep 22 15:46:51 2010 +0900 @@ -30,17 +30,20 @@ (eval-when-compile (require 'cl)) ; block, return (require 'tramp) -(require 'tramp-cache) -(require 'tramp-compat) + +;; We call several `tramp-handle-*' functions directly. So we must +;; reqire that package as well. +(require 'tramp-sh) ;; Define SMB method ... -(defcustom tramp-smb-method "smb" - "*Method to connect SAMBA and M$ SMB servers." - :group 'tramp - :type 'string) +;;;###tramp-autoload +(defconst tramp-smb-method "smb" + "*Method to connect SAMBA and M$ SMB servers.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-smb-method nil)) +;;;###tramp-autoload +(unless (memq system-type '(cygwin windows-nt)) + (add-to-list 'tramp-methods (cons tramp-smb-method nil))) ;; Add a default for `tramp-default-method-alist'. Rule: If there is ;; a domain in USER, it must be the SMB method. @@ -205,11 +208,13 @@ "Alist of handler functions for Tramp SMB method. Operations not mentioned here will be handled by the default Emacs primitives.") -(defun tramp-smb-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." (let ((v (tramp-dissect-file-name filename))) (string= (tramp-file-name-method v) tramp-smb-method))) +;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) "Invoke the SMB related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -219,8 +224,10 @@ (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args)))) -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler)) +;;;###tramp-autoload +(unless (memq system-type '(cygwin windows-nt)) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))) ;; File name primitives. @@ -784,7 +791,7 @@ (if (tramp-smb-get-cifs-capabilities v) (format "posix_mkdir \"%s\" %s" - file (tramp-decimal-to-octal (default-file-modes))) + file (tramp-compat-decimal-to-octal (default-file-modes))) (format "mkdir \"%s\"" file))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. @@ -893,7 +900,7 @@ (unless (tramp-smb-send-command v (format "chmod \"%s\" %s" (tramp-smb-get-localname v) - (tramp-decimal-to-octal mode))) + (tramp-compat-decimal-to-octal mode))) (tramp-error v 'file-error "Error while changing file's mode %s" filename))))) @@ -1397,6 +1404,9 @@ (tramp-message vec 6 "\n%s" (buffer-string)) (not err)))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-smb 'force))) (provide 'tramp-smb)
--- a/lisp/net/tramp-uu.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp-uu.el Wed Sep 22 15:46:51 2010 +0900 @@ -50,6 +50,7 @@ "Return the byte that is encoded as CHAR." (cdr (assq char tramp-uu-b64-char-to-byte))) +;;;###tramp-autoload (defun tramp-uuencode-region (beg end) "UU-encode the region between BEG and END." ;; First we base64 encode the region, then we transmogrify that into @@ -87,6 +88,10 @@ (goto-char beg) (insert "begin 600 xxx\n")))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-uu 'force))) + (provide 'tramp-uu) ;; arch-tag: 7153f2c6-8be5-4cd2-8c06-0fbcf5190ef6
--- a/lisp/net/tramp.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/tramp.el Wed Sep 22 15:46:51 2010 +0900 @@ -3,11 +3,10 @@ ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. -;; (copyright statements below in code to be updated with the above notice) - ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -59,117 +58,7 @@ ;;; Code: -;; Since Emacs 23.1, loading messages have been disabled during -;; autoload. However, loading Tramp takes a while, and it could -;; happen while typing a filename in the minibuffer. Therefore, Tramp -;; shall inform about. -(when (and load-in-progress (null (current-message))) - (message "Loading tramp...")) - -;; The Tramp version number and bug report address, as prepared by configure. -(require 'trampver) -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'trampver) - (unload-feature 'trampver 'force)))) - (require 'tramp-compat) -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-compat) - (unload-feature 'tramp-compat 'force)))) - -(require 'format-spec) -;; As long as password.el is not part of (X)Emacs, it shouldn't -;; be mandatory -(if (featurep 'xemacs) - (load "password" 'noerror) - (or (require 'password-cache nil 'noerror) - (require 'password nil 'noerror))) ; from No Gnus, also in tar ball - -(require 'shell) -(require 'advice) - -(eval-and-compile - (if (featurep 'xemacs) - (load "auth-source" 'noerror) - (require 'auth-source nil 'noerror))) - -;; Requiring 'tramp-cache results in an endless loop. -(autoload 'tramp-get-file-property "tramp-cache") -(autoload 'tramp-set-file-property "tramp-cache") -(autoload 'tramp-flush-file-property "tramp-cache") -(autoload 'tramp-flush-directory-property "tramp-cache") -(autoload 'tramp-get-connection-property "tramp-cache") -(autoload 'tramp-set-connection-property "tramp-cache") -(autoload 'tramp-flush-connection-property "tramp-cache") -(autoload 'tramp-parse-connection-properties "tramp-cache") -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-cache) - (unload-feature 'tramp-cache 'force)))) - -(autoload 'tramp-uuencode-region "tramp-uu" - "Implementation of `uuencode' in Lisp.") -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-uu) - (unload-feature 'tramp-uu 'force)))) - -(autoload 'uudecode-decode-region "uudecode") - -;; The following Tramp packages must be loaded after tramp.el, because -;; they require it as well. -(eval-after-load "tramp" - '(dolist - (feature - (list - - ;; Tramp interactive commands. - 'tramp-cmds - - ;; Load foreign FTP method. - (if (featurep 'xemacs) 'tramp-efs 'tramp-ftp) - - ;; tramp-smb uses "smbclient" from Samba. Not available - ;; under Cygwin and Windows, because they don't offer - ;; "smbclient". And even not necessary there, because Emacs - ;; supports UNC file names like "//host/share/localname". - (unless (memq system-type '(cygwin windows-nt)) 'tramp-smb) - - ;; Load foreign FISH method. - 'tramp-fish - - ;; tramp-gvfs needs D-Bus messages. Available since Emacs 23 - ;; on some system types. We don't call `dbus-ping', because - ;; this would load dbus.el. - (when (and (featurep 'dbusbind) - (condition-case nil - (tramp-compat-funcall 'dbus-get-unique-name :session) - (error nil)) - (tramp-compat-process-running-p "gvfs-fuse-daemon")) - 'tramp-gvfs) - - ;; Load gateways. It needs `make-network-process' from Emacs 22. - (when (functionp 'make-network-process) 'tramp-gw) - - ;; tramp-imap needs both epa (from Emacs 23.1) and imap-hash - ;; (from Emacs 23.2). - (when (and (locate-library "epa") (locate-library "imap-hash")) - 'tramp-imap))) - - (when feature - ;; We have used just some basic tests, whether a package shall - ;; be added. There might still be other errors during loading, - ;; which we will catch here. - (catch 'tramp-loading - (require feature) - (add-hook 'tramp-unload-hook - `(lambda () - (when (featurep (quote ,feature)) - (unload-feature (quote ,feature) 'force))))) - (unless (featurep feature) - (message "Loading %s failed, ignoring this package" feature))))) ;;; User Customizable Internal Variables: @@ -286,379 +175,8 @@ :group 'tramp :type 'string) -(defcustom tramp-inline-compress-start-size 4096 - "*The minimum size of compressing where inline transfer. -When inline transfer, compress transfered data of file -whose size is this value or above (up to `tramp-copy-size-limit'). -If it is nil, no compression at all will be applied." - :group 'tramp - :type '(choice (const nil) integer)) - -(defcustom tramp-copy-size-limit 10240 - "*The maximum file size where inline copying is preferred over an out-of-the-band copy. -If it is nil, inline out-of-the-band copy will be used without a check." - :group 'tramp - :type '(choice (const nil) integer)) - -(defcustom tramp-terminal-type "dumb" - "*Value of TERM environment variable for logging in to remote host. -Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init -files conditionalize this setup based on the TERM environment variable." - :group 'tramp - :type 'string) - -;; ksh on OpenBSD 4.5 requires, that PS1 contains a `#' character for -;; root users. It uses the `$' character for other users. In order -;; to guarantee a proper prompt, we use "#$" for the prompt. - -(defvar tramp-end-of-output - (format - "///%s#$" - (md5 (concat (prin1-to-string process-environment) (current-time-string)))) - "String used to recognize end of output. -The '$' character at the end is quoted; the string cannot be -detected as prompt when being sent on echoing hosts, therefore.") - -(defconst tramp-initial-end-of-output "#$ " - "Prompt when establishing a connection.") - -(defvar tramp-methods - `(("rcp" (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("scp" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp1" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-1") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp2" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-2") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp1_old" - (tramp-login-program "ssh1") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp1") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("scp2_old" - (tramp-login-program "ssh2") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp2") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("sftp" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "sftp") - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("rsync" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rsync") - (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("rsyncc" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=yes") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rsync") - (tramp-copy-args (("-t" "%k") ("-r"))) - (tramp-copy-env (("RSYNC_RSH") - (,(concat - "ssh" - " -o ControlPath=%t.%%r@%%h:%%p" - " -o ControlMaster=auto")))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("remcp" (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil)) - ("rsh" (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("ssh" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh1" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-1") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh2" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-2") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh1_old" - (tramp-login-program "ssh1") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("ssh2_old" - (tramp-login-program "ssh2") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("remsh" (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("telnet" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-default-port 23)) - ("su" (tramp-login-program "su") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("sudo" (tramp-login-program "sudo") - (tramp-login-args (("-u" "%u") - ("-s") ("-H") ("-p" "Password:"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("scpc" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=yes") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=auto"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scpx" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("-t" "-t") - ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("sshx" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("-t" "-t") - ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("krlogin" - (tramp-login-program "krlogin") - (tramp-login-args (("%h") ("-l" "%u") ("-x"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("plink" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("plink1" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-1" "-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("plinkx" - (tramp-login-program "plink") - ;; ("%h") must be a single element, see - ;; `tramp-compute-multi-hops'. - (tramp-login-args (("-load") ("%h") ("-t") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("pscp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("psftp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line "xy")) ;see docstring for "xy" - ("fcp" (tramp-login-program "fsh") - (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) - (tramp-remote-sh "/bin/sh -i") - (tramp-copy-program "fcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil))) +;;;###tramp-autoload +(defvar tramp-methods nil "*Alist of methods for remote files. This is a list of entries of the form (NAME PARAM1 PARAM2 ...). Each NAME stands for a remote access method. Each PARAM is a @@ -800,8 +318,7 @@ :group 'tramp :type 'string) -(defcustom tramp-default-method-alist - '(("\\`localhost\\'" "\\`root\\'" "su")) +(defcustom tramp-default-method-alist nil "*Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item specifies the method to use for a file name which does not specify a @@ -818,8 +335,7 @@ (regexp :tag "User regexp") (string :tag "Method")))) -(defcustom tramp-default-user - nil +(defcustom tramp-default-user nil "*Default user to use for transferring files. It is nil by default; otherwise settings in configuration files like \"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'. @@ -828,10 +344,7 @@ :group 'tramp :type '(choice (const nil) string)) -(defcustom tramp-default-user-alist - `(("\\`su\\(do\\)?\\'" nil "root") - ("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'" - nil ,(user-login-name))) +(defcustom tramp-default-user-alist nil "*Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a @@ -846,8 +359,7 @@ (regexp :tag "Host regexp") (string :tag "User")))) -(defcustom tramp-default-host - (system-name) +(defcustom tramp-default-host (system-name) "*Default host to use for transferring files. Useful for su and sudo methods mostly." :group 'tramp @@ -877,39 +389,6 @@ "^" (regexp-opt (list "localhost" (system-name) "127\.0\.0\.1" "::1") t) "$") "*Host names which are regarded as local host.") -(defconst tramp-completion-function-alist-rsh - '((tramp-parse-rhosts "/etc/hosts.equiv") - (tramp-parse-rhosts "~/.rhosts")) - "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.") - -(defconst tramp-completion-function-alist-ssh - '((tramp-parse-rhosts "/etc/hosts.equiv") - (tramp-parse-rhosts "/etc/shosts.equiv") - (tramp-parse-shosts "/etc/ssh_known_hosts") - (tramp-parse-sconfig "/etc/ssh_config") - (tramp-parse-shostkeys "/etc/ssh2/hostkeys") - (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") - (tramp-parse-rhosts "~/.rhosts") - (tramp-parse-rhosts "~/.shosts") - (tramp-parse-shosts "~/.ssh/known_hosts") - (tramp-parse-sconfig "~/.ssh/config") - (tramp-parse-shostkeys "~/.ssh2/hostkeys") - (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) - "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") - -(defconst tramp-completion-function-alist-telnet - '((tramp-parse-hosts "/etc/hosts")) - "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.") - -(defconst tramp-completion-function-alist-su - '((tramp-parse-passwd "/etc/passwd")) - "Default list of (FUNCTION FILE) pairs to be examined for su methods.") - -(defconst tramp-completion-function-alist-putty - '((tramp-parse-putty - "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions")) - "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.") - (defvar tramp-completion-function-alist nil "*Alist of methods for remote files. This is a list of entries of the form \(NAME PAIR1 PAIR2 ...\). @@ -930,63 +409,6 @@ FUNCTION can also be a customer defined function. For more details see the info pages.") -(eval-after-load "tramp" - '(progn - (tramp-set-completion-function - "rcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "scp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp2" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp1_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp2_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "rsync" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "rsyncc" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "remcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "rsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "ssh" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh2" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh1_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh2_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "remsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "telnet" tramp-completion-function-alist-telnet) - (tramp-set-completion-function - "su" tramp-completion-function-alist-su) - (tramp-set-completion-function - "sudo" tramp-completion-function-alist-su) - (tramp-set-completion-function - "scpx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "sshx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "krlogin" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "plink" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plink1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plinkx" tramp-completion-function-alist-putty) - (tramp-set-completion-function - "pscp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "fcp" tramp-completion-function-alist-ssh))) - (defconst tramp-echo-mark-marker "_echo" "String marker to surround echoed commands.") @@ -1035,55 +457,6 @@ :group 'tramp :type 'string) -;; "getconf PATH" yields: -;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin -;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse): /bin:/usr/bin -;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! -;; IRIX64: /usr/bin -(defcustom tramp-remote-path - '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin" - "/local/bin" "/local/freeware/bin" "/local/gnu/bin" - "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") - "*List of directories to search for executables on remote host. -For every remote host, this variable will be set buffer local, -keeping the list of existing directories on that host. - -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. - -`Default Directories' represent the list of directories given by -the command \"getconf PATH\". It is recommended to use this -entry on top of this list, because these are the default -directories for POSIX compatible commands. - -`Private Directories' are the settings of the $PATH environment, -as given in your `~/.profile'." - :group 'tramp - :type '(repeat (choice - (const :tag "Default Directories" tramp-default-remote-path) - (const :tag "Private Directories" tramp-own-remote-path) - (string :tag "Directory")))) - -(defcustom tramp-remote-process-environment - `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C" - ,(format "TERM=%s" tramp-terminal-type) - "EMACS=t" ;; Deprecated. - ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" - "autocorrect=" "correct=") - - "*List of environment variables to be set on the remote host. - -Each element should be a string of the form ENVVARNAME=VALUE. An -entry ENVVARNAME= diables the corresponding environment variable, -which might have been set in the init files like ~/.profile. - -Special handling is applied to the PATH environment, which should -not be set here. Instead of, it should be set via `tramp-remote-path'." - :group 'tramp - :type '(repeat string)) - (defcustom tramp-login-prompt-regexp ".*ogin\\( .*\\)?: *" "*Regexp matching login-like prompts. @@ -1211,15 +584,13 @@ :group 'tramp :type 'regexp) -(defcustom tramp-temp-name-prefix "tramp." +(defconst tramp-temp-name-prefix "tramp." "*Prefix to use for temporary files. If this is a relative file name (such as \"tramp.\"), it is considered relative to the directory name returned by the function `tramp-compat-temporary-file-directory' (which see). It may also be an absolute file name; don't forget to include a prefix for the filename -part, though." - :group 'tramp - :type 'string) +part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -1230,22 +601,6 @@ Useful for \"rsync\" like methods.") (make-variable-buffer-local 'tramp-temp-buffer-file-name) -(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) - "*Alist specifying extra arguments to pass to the remote shell. -Entries are (REGEXP . ARGS) where REGEXP is a regular expression -matching the shell file name and ARGS is a string specifying the -arguments. - -This variable is only used when Tramp needs to start up another shell -for tilde expansion. The extra arguments should typically prevent the -shell from reading its init file." - :group 'tramp - ;; This might be the wrong way to test whether the widget type - ;; `alist' is available. Who knows the right way to test it? - :type (if (get 'alist 'widget-type) - '(alist :key-type string :value-type string) - '(repeat (cons string string)))) - ;; XEmacs is distributed with few Lisp packages. Further packages are ;; installed using EFS. If we use a unified filename format, then ;; Tramp is required in addition to EFS. (But why can't Tramp just @@ -1304,8 +659,7 @@ "*Regexp matching delimeter between method and user or host names. Derived from `tramp-postfix-method-format'.") -(defconst tramp-user-regexp - "[^:/ \t]+" +(defconst tramp-user-regexp "[^:/ \t]+" "*Regexp matching user names.") (defconst tramp-prefix-domain-format "%" @@ -1316,8 +670,7 @@ "*Regexp matching delimeter between user and domain names. Derived from `tramp-prefix-domain-format'.") -(defconst tramp-domain-regexp - "[-a-zA-Z0-9_.]+" +(defconst tramp-domain-regexp "[-a-zA-Z0-9_.]+" "*Regexp matching domain names.") (defconst tramp-user-with-domain-regexp @@ -1326,8 +679,7 @@ "\\(" tramp-domain-regexp "\\)") "*Regexp matching user names with domain names.") -(defconst tramp-postfix-user-format - "@" +(defconst tramp-postfix-user-format "@" "*String matching delimeter between user and host names. Used in `tramp-make-tramp-file-name'.") @@ -1336,8 +688,7 @@ "*Regexp matching delimeter between user and host names. Derived from `tramp-postfix-user-format'.") -(defconst tramp-host-regexp - "[a-zA-Z0-9_.-]+" +(defconst tramp-host-regexp "[a-zA-Z0-9_.-]+" "*Regexp matching host names.") (defconst tramp-prefix-ipv6-format @@ -1385,8 +736,7 @@ "*Regexp matching delimeter between host names and port numbers. Derived from `tramp-prefix-port-format'.") -(defconst tramp-port-regexp - "[0-9]+" +(defconst tramp-port-regexp "[0-9]+" "*Regexp matching port numbers.") (defconst tramp-host-with-port-regexp @@ -1408,8 +758,7 @@ "*Regexp matching delimeter between host names and localnames. Derived from `tramp-postfix-host-format'.") -(defconst tramp-localname-regexp - ".*$" +(defconst tramp-localname-regexp ".*$" "*Regexp matching localnames.") ;; File name format. @@ -1457,15 +806,13 @@ On W32 systems, the volume letter must be ignored.") ;;;###autoload -(defconst tramp-file-name-regexp-separate - "\\`/\\[.*\\]" +(defconst tramp-file-name-regexp-separate "\\`/\\[.*\\]" "Value for `tramp-file-name-regexp' for separate remoting. XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload -(defconst tramp-file-name-regexp-url - "\\`/[^/:]+://" +(defconst tramp-file-name-regexp-url "\\`/[^/:]+://" "Value for `tramp-file-name-regexp' for URL-like remoting. See `tramp-file-name-structure' for more explanations.") @@ -1539,38 +886,6 @@ Also see `tramp-file-name-structure'.") -(defconst tramp-actions-before-shell - '((tramp-login-prompt-regexp tramp-action-login) - (tramp-password-prompt-regexp tramp-action-password) - (tramp-wrong-passwd-regexp tramp-action-permission-denied) - (shell-prompt-pattern tramp-action-succeed) - (tramp-shell-prompt-pattern tramp-action-succeed) - (tramp-yesno-prompt-regexp tramp-action-yesno) - (tramp-yn-prompt-regexp tramp-action-yn) - (tramp-terminal-prompt-regexp tramp-action-terminal) - (tramp-process-alive-regexp tramp-action-process-alive)) - "List of pattern/action pairs. -Whenever a pattern matches, the corresponding action is performed. -Each item looks like (PATTERN ACTION). - -The PATTERN should be a symbol, a variable. The value of this -variable gives the regular expression to search for. Note that the -regexp must match at the end of the buffer, \"\\'\" is implicitly -appended to it. - -The ACTION should also be a symbol, but a function. When the -corresponding PATTERN matches, the ACTION function is called.") - -(defconst tramp-actions-copy-out-of-band - '((tramp-password-prompt-regexp tramp-action-password) - (tramp-wrong-passwd-regexp tramp-action-permission-denied) - (tramp-copy-failed-regexp tramp-action-permission-denied) - (tramp-process-alive-regexp tramp-action-out-of-band)) - "List of pattern/action pairs. -This list is used for copying/renaming with out-of-band methods. - -See `tramp-actions-before-shell' for more info.") - ;; Chunked sending kludge. We set this to 500 for black-listed constellations ;; known to have a bug in `process-send-string'; some ssh connections appear ;; to drop bytes when data is sent too quickly. There is also a connection @@ -1676,437 +991,273 @@ (defvar tramp-current-host nil "Remote host for this *tramp* buffer.") -(defconst tramp-uudecode - "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode -cat /tmp/tramp.$$ -rm -f /tmp/tramp.$$" - "Shell function to implement `uudecode' to standard output. -Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' -for this or `uudecode -p', but some systems don't, and for them -we have this shell function.") - -(defconst tramp-perl-file-truename - "%s -e ' -use File::Spec; -use Cwd \"realpath\"; - -sub recursive { - my ($volume, @dirs) = @_; - my $real = realpath(File::Spec->catpath( - $volume, File::Spec->catdir(@dirs), \"\")); - if ($real) { - my ($vol, $dir) = File::Spec->splitpath($real, 1); - return ($vol, File::Spec->splitdir($dir)); - } - else { - my $last = pop(@dirs); - ($volume, @dirs) = recursive($volume, @dirs); - push(@dirs, $last); - return ($volume, @dirs); - } -} - -$result = realpath($ARGV[0]); -if (!$result) { - my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1); - ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir)); - - $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\"); -} - -if ($ARGV[0] =~ /\\/$/) { - $result = $result . \"/\"; -} - -print \"\\\"$result\\\"\\n\"; -' \"$1\" 2>/dev/null" - "Perl script to produce output suitable for use with `file-truename' -on the remote file system. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-file-name-all-completions - "%s -e 'sub case { - my $str = shift; - if ($ARGV[2]) { - return lc($str); - } - else { - return $str; - } -} -opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); -@files = readdir(d); closedir(d); -foreach $f (@files) { - if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) { - if (-d \"$ARGV[0]/$f\") { - print \"$f/\\n\"; - } - else { - print \"$f\\n\"; - } - } -} -print \"ok\\n\" -' \"$1\" \"$2\" \"$3\" 2>/dev/null" - "Perl script to produce output suitable for use with -`file-name-all-completions' on the remote file system. Escape -sequence %s is replaced with name of Perl binary. This string is -passed to `format', so percent characters need to be doubled.") - -;; Perl script to implement `file-attributes' in a Lisp `read'able -;; output. If you are hacking on this, note that you get *no* output -;; unless this spits out a complete line, including the '\n' at the -;; end. -;; The device number is returned as "-1", because there will be a virtual -;; device number set in `tramp-handle-file-attributes'. -(defconst tramp-perl-file-attributes - "%s -e ' -@stat = lstat($ARGV[0]); -if (!@stat) { - print \"nil\\n\"; - exit 0; -} -if (($stat[2] & 0170000) == 0120000) -{ - $type = readlink($ARGV[0]); - $type = \"\\\"$type\\\"\"; -} -elsif (($stat[2] & 0170000) == 040000) -{ - $type = \"t\"; -} -else -{ - $type = \"nil\" -}; -$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; -$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; -printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", - $type, - $stat[3], - $uid, - $gid, - $stat[8] >> 16 & 0xffff, - $stat[8] & 0xffff, - $stat[9] >> 16 & 0xffff, - $stat[9] & 0xffff, - $stat[10] >> 16 & 0xffff, - $stat[10] & 0xffff, - $stat[7], - $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff -);' \"$1\" \"$2\" 2>/dev/null" - "Perl script to produce output suitable for use with `file-attributes' -on the remote file system. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-directory-files-and-attributes - "%s -e ' -chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); -opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit(); -@list = readdir(DIR); -closedir(DIR); -$n = scalar(@list); -printf(\"(\\n\"); -for($i = 0; $i < $n; $i++) -{ - $filename = $list[$i]; - @stat = lstat($filename); - if (($stat[2] & 0170000) == 0120000) - { - $type = readlink($filename); - $type = \"\\\"$type\\\"\"; - } - elsif (($stat[2] & 0170000) == 040000) - { - $type = \"t\"; - } - else - { - $type = \"nil\" - }; - $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; - $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; - printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", - $filename, - $type, - $stat[3], - $uid, - $gid, - $stat[8] >> 16 & 0xffff, - $stat[8] & 0xffff, - $stat[9] >> 16 & 0xffff, - $stat[9] & 0xffff, - $stat[10] >> 16 & 0xffff, - $stat[10] & 0xffff, - $stat[7], - $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff, - $stat[0] >> 16 & 0xffff, - $stat[0] & 0xffff); -} -printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null" - "Perl script implementing `directory-files-attributes' as Lisp `read'able -output. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -;; ;; These two use uu encoding. -;; (defvar tramp-perl-encode "%s -e'\ -;; print qq(begin 644 xxx\n); -;; my $s = q(); -;; my $res = q(); -;; while (read(STDIN, $s, 45)) { -;; print pack(q(u), $s); -;; } -;; print qq(`\n); -;; print qq(end\n); -;; '" -;; "Perl program to use for encoding a file. -;; Escape sequence %s is replaced with name of Perl binary.") - -;; (defvar tramp-perl-decode "%s -ne ' -;; print unpack q(u), $_; -;; '" -;; "Perl program to use for decoding a file. -;; Escape sequence %s is replaced with name of Perl binary.") - -;; These two use base64 encoding. -(defconst tramp-perl-encode-with-module - "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null" - "Perl program to use for encoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled. -This implementation requires the MIME::Base64 Perl module to be installed -on the remote host.") - -(defconst tramp-perl-decode-with-module - "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null" - "Perl program to use for decoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled. -This implementation requires the MIME::Base64 Perl module to be installed -on the remote host.") - -(defconst tramp-perl-encode - "%s -e ' -# This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -# Free Software Foundation, Inc. -use strict; - -my %%trans = do { - my $i = 0; - map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)} - split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/); -}; - -binmode(\\*STDIN); - -# We read in chunks of 54 bytes, to generate output lines -# of 72 chars (plus end of line) -$/ = \\54; - -while (my $data = <STDIN>) { - my $pad = q(); - - # Only for the last chunk, and only if did not fill the last three-byte packet - if (eof) { - my $mod = length($data) %% 3; - $pad = q(=) x (3 - $mod) if $mod; - } - - # Not the fastest method, but it is simple: unpack to binary string, split - # by groups of 6 bits and convert back from binary to byte; then map into - # the translation table - print - join q(), - map($trans{$_}, - (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)), - $pad, - qq(\\n); -}' 2>/dev/null" - "Perl program to use for encoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-decode - "%s -e ' -# This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -# Free Software Foundation, Inc. -use strict; - -my %%trans = do { - my $i = 0; - map {($_, substr(unpack(q(B8), chr $i++), 2, 6))} - split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/) -}; - -my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255; - -binmode(\\*STDOUT); - -# We are going to accumulate into $pending to accept any line length -# (we do not check they are <= 76 chars as the RFC says) -my $pending = q(); - -while (my $data = <STDIN>) { - chomp $data; - - # If we find one or two =, we have reached the end and - # any following data is to be discarded - my $finished = $data =~ s/(==?).*/$1/; - $pending .= $data; - - my $len = length($pending); - my $chunk = substr($pending, 0, $len & ~3); - $pending = substr($pending, $len & ~3 + 1); - - # Easy method: translate from chars to (pregenerated) six-bit packets, join, - # split in 8-bit chunks and convert back to char. - print join q(), - map $bytes{$_}, - ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g); - - last if $finished; -}' 2>/dev/null" - "Perl program to use for decoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-vc-registered-read-file-names - "echo \"(\" -while read file; do - if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" - else - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" - fi - if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" - else - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" - fi -done -echo \")\"" - "Script to check existence of VC related files. -It must be send formatted with two strings; the tests for file -existence, and file readability. Input shall be read via -here-document, otherwise the command could exceed maximum length -of command line.") - -(defconst tramp-file-mode-type-map - '((0 . "-") ; Normal file (SVID-v2 and XPG2) - (1 . "p") ; fifo - (2 . "c") ; character device - (3 . "m") ; multiplexed character device (v7) - (4 . "d") ; directory - (5 . "?") ; Named special file (XENIX) - (6 . "b") ; block device - (7 . "?") ; multiplexed block device (v7) - (8 . "-") ; regular file - (9 . "n") ; network special file (HP-UX) - (10 . "l") ; symlink - (11 . "?") ; ACL shadow inode (Solaris, not userspace) - (12 . "s") ; socket - (13 . "D") ; door special (Solaris) - (14 . "w")) ; whiteout (BSD) - "A list of file types returned from the `stat' system call. -This is used to map a mode number to a permission string.") - -;; New handlers should be added here. The following operations can be -;; handled using the normal primitives: file-name-sans-versions, -;; get-file-buffer. -(defconst tramp-file-name-handler-alist - '((load . tramp-handle-load) - (make-symbolic-link . tramp-handle-make-symbolic-link) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (file-name-directory . tramp-handle-file-name-directory) - (file-name-nondirectory . tramp-handle-file-name-nondirectory) - (file-truename . tramp-handle-file-truename) - (file-exists-p . tramp-handle-file-exists-p) - (file-directory-p . tramp-handle-file-directory-p) - (file-executable-p . tramp-handle-file-executable-p) - (file-readable-p . tramp-handle-file-readable-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-symlink-p . tramp-handle-file-symlink-p) - (file-writable-p . tramp-handle-file-writable-p) - (file-ownership-preserved-p . tramp-handle-file-ownership-preserved-p) - (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) - (file-attributes . tramp-handle-file-attributes) - (file-modes . tramp-handle-file-modes) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - (file-name-all-completions . tramp-handle-file-name-all-completions) - (file-name-completion . tramp-handle-file-name-completion) - (add-name-to-file . tramp-handle-add-name-to-file) - (copy-file . tramp-handle-copy-file) - (copy-directory . tramp-handle-copy-directory) - (rename-file . tramp-handle-rename-file) - (set-file-modes . tramp-handle-set-file-modes) - (set-file-times . tramp-handle-set-file-times) - (make-directory . tramp-handle-make-directory) - (delete-directory . tramp-handle-delete-directory) - (delete-file . tramp-handle-delete-file) - (directory-file-name . tramp-handle-directory-file-name) - ;; `executable-find' is not official yet. - (executable-find . tramp-handle-executable-find) - (start-file-process . tramp-handle-start-file-process) - (process-file . tramp-handle-process-file) - (shell-command . tramp-handle-shell-command) - (insert-directory . tramp-handle-insert-directory) - (expand-file-name . tramp-handle-expand-file-name) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (file-local-copy . tramp-handle-file-local-copy) - (file-remote-p . tramp-handle-file-remote-p) - (insert-file-contents . tramp-handle-insert-file-contents) - (insert-file-contents-literally - . tramp-handle-insert-file-contents-literally) - (write-region . tramp-handle-write-region) - (find-backup-file-name . tramp-handle-find-backup-file-name) - (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (dired-compress-file . tramp-handle-dired-compress-file) - (dired-recursive-delete-directory - . tramp-handle-dired-recursive-delete-directory) - (dired-uncache . tramp-handle-dired-uncache) - (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) - (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (file-selinux-context . tramp-handle-file-selinux-context) - (set-file-selinux-context . tramp-handle-set-file-selinux-context) - (vc-registered . tramp-handle-vc-registered)) - "Alist of handler functions. -Operations not mentioned here will be handled by the normal Emacs functions.") - -;; Handlers for partial Tramp file names. For Emacs just -;; `file-name-all-completions' is needed. ;;;###autoload (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) (file-name-completion . tramp-completion-handle-file-name-completion)) "Alist of completion handler functions. -Used for file names matching `tramp-file-name-regexp'. Operations not -mentioned here will be handled by `tramp-file-name-handler-alist' or the -normal Emacs functions.") +Used for file names matching `tramp-file-name-regexp'. Operations +not mentioned here will be handled by Tramp's file name handler +functions, or the normal Emacs functions.") ;; Handlers for foreign methods, like FTP or SMB, shall be plugged here. -(defvar tramp-foreign-file-name-handler-alist - ;; (identity . tramp-sh-file-name-handler) should always be the last - ;; entry, because `identity' always matches. - '((identity . tramp-sh-file-name-handler)) +;;;###tramp-autoload +(defvar tramp-foreign-file-name-handler-alist nil "Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially. If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by calling HANDLER.") ;;; Internal functions which must come first: + +;; ------------------------------------------------------------ +;; -- Tramp file names -- +;; ------------------------------------------------------------ +;; Conversion functions between external representation and +;; internal data structure. Convenience functions for internal +;; data structure. + +(defun tramp-file-name-p (vec) + "Check, whether VEC is a Tramp object." + (and (vectorp vec) (= 4 (length vec)))) + +(defun tramp-file-name-method (vec) + "Return method component of VEC." + (and (tramp-file-name-p vec) (aref vec 0))) + +(defun tramp-file-name-user (vec) + "Return user component of VEC." + (and (tramp-file-name-p vec) (aref vec 1))) + +(defun tramp-file-name-host (vec) + "Return host component of VEC." + (and (tramp-file-name-p vec) (aref vec 2))) + +(defun tramp-file-name-localname (vec) + "Return localname component of VEC." + (and (tramp-file-name-p vec) (aref vec 3))) + +;; The user part of a Tramp file name vector can be of kind +;; "user%domain". Sometimes, we must extract these parts. +(defun tramp-file-name-real-user (vec) + "Return the user name of VEC without domain." + (save-match-data + (let ((user (tramp-file-name-user vec))) + (if (and (stringp user) + (string-match tramp-user-with-domain-regexp user)) + (match-string 1 user) + user)))) + +(defun tramp-file-name-domain (vec) + "Return the domain name of VEC." + (save-match-data + (let ((user (tramp-file-name-user vec))) + (and (stringp user) + (string-match tramp-user-with-domain-regexp user) + (match-string 2 user))))) + +;; The host part of a Tramp file name vector can be of kind +;; "host#port". Sometimes, we must extract these parts. +(defun tramp-file-name-real-host (vec) + "Return the host name of VEC without port." + (save-match-data + (let ((host (tramp-file-name-host vec))) + (if (and (stringp host) + (string-match tramp-host-with-port-regexp host)) + (match-string 1 host) + host)))) + +(defun tramp-file-name-port (vec) + "Return the port number of VEC." + (save-match-data + (let ((host (tramp-file-name-host vec))) + (and (stringp host) + (string-match tramp-host-with-port-regexp host) + (string-to-number (match-string 2 host)))))) + +;;;###tramp-autoload +(defun tramp-tramp-file-p (name) + "Return t if NAME is a string with Tramp file name syntax." + (save-match-data + (and (stringp name) (string-match tramp-file-name-regexp name)))) + +(defun tramp-find-method (method user host) + "Return the right method string to use. +This is METHOD, if non-nil. Otherwise, do a lookup in +`tramp-default-method-alist'." + (or method + (let ((choices tramp-default-method-alist) + lmethod item) + (while choices + (setq item (pop choices)) + (when (and (string-match (or (nth 0 item) "") (or host "")) + (string-match (or (nth 1 item) "") (or user ""))) + (setq lmethod (nth 2 item)) + (setq choices nil))) + lmethod) + tramp-default-method)) + +(defun tramp-find-user (method user host) + "Return the right user string to use. +This is USER, if non-nil. Otherwise, do a lookup in +`tramp-default-user-alist'." + (or user + (let ((choices tramp-default-user-alist) + luser item) + (while choices + (setq item (pop choices)) + (when (and (string-match (or (nth 0 item) "") (or method "")) + (string-match (or (nth 1 item) "") (or host ""))) + (setq luser (nth 2 item)) + (setq choices nil))) + luser) + tramp-default-user)) + +(defun tramp-find-host (method user host) + "Return the right host string to use. +This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." + (or (and (> (length host) 0) host) + tramp-default-host)) + +(defun tramp-dissect-file-name (name &optional nodefault) + "Return a `tramp-file-name' structure. +The structure consists of remote method, remote user, remote host +and localname (file name on remote host). If NODEFAULT is +non-nil, the file name parts are not expanded to their default +values." + (save-match-data + (let ((match (string-match (nth 0 tramp-file-name-structure) name))) + (unless match (error "Not a Tramp file name: %s" name)) + (let ((method (match-string (nth 1 tramp-file-name-structure) name)) + (user (match-string (nth 2 tramp-file-name-structure) name)) + (host (match-string (nth 3 tramp-file-name-structure) name)) + (localname (match-string (nth 4 tramp-file-name-structure) name))) + (when host + (when (string-match tramp-prefix-ipv6-regexp host) + (setq host (replace-match "" nil t host))) + (when (string-match tramp-postfix-ipv6-regexp host) + (setq host (replace-match "" nil t host)))) + (if nodefault + (vector method user host localname) + (vector + (tramp-find-method method user host) + (tramp-find-user method user host) + (tramp-find-host method user host) + localname)))))) + +(defun tramp-buffer-name (vec) + "A name for the connection buffer VEC." + ;; We must use `tramp-file-name-real-host', because for gateway + ;; methods the default port will be expanded later on, which would + ;; tamper the name. + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec))) + (if (not (zerop (length user))) + (format "*tramp/%s %s@%s*" method user host) + (format "*tramp/%s %s*" method host)))) + +(defun tramp-make-tramp-file-name (method user host localname) + "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME." + (concat tramp-prefix-format + (when (not (zerop (length method))) + (concat method tramp-postfix-method-format)) + (when (not (zerop (length user))) + (concat user tramp-postfix-user-format)) + (when host + (if (string-match tramp-ipv6-regexp host) + (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + tramp-postfix-host-format + (when localname localname))) + +(defun tramp-completion-make-tramp-file-name (method user host localname) + "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. +It must not be a complete Tramp file name, but as long as there are +necessary only. This function will be used in file name completion." + (concat tramp-prefix-format + (when (not (zerop (length method))) + (concat method tramp-postfix-method-format)) + (when (not (zerop (length user))) + (concat user tramp-postfix-user-format)) + (when (not (zerop (length host))) + (concat + (if (string-match tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host) + tramp-postfix-host-format)) + (when localname localname))) + +(defun tramp-get-buffer (vec) + "Get the connection buffer to be used for VEC." + (or (get-buffer (tramp-buffer-name vec)) + (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) + (setq buffer-undo-list t) + (setq default-directory + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + "/")) + (current-buffer)))) + +(defun tramp-get-connection-buffer (vec) + "Get the connection buffer to be used for VEC. +In case a second asynchronous communication has been started, it is different +from `tramp-get-buffer'." + (or (tramp-get-connection-property vec "process-buffer" nil) + (tramp-get-buffer vec))) + +(defun tramp-get-connection-process (vec) + "Get the connection process to be used for VEC. +In case a second asynchronous communication has been started, it is different +from the default one." + (get-process + (or (tramp-get-connection-property vec "process-name" nil) + (tramp-buffer-name vec)))) + +(defun tramp-debug-buffer-name (vec) + "A name for the debug buffer for VEC." + ;; We must use `tramp-file-name-real-host', because for gateway + ;; methods the default port will be expanded later on, which would + ;; tamper the name. + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec))) + (if (not (zerop (length user))) + (format "*debug tramp/%s %s@%s*" method user host) + (format "*debug tramp/%s %s*" method host)))) + +(defconst tramp-debug-outline-regexp + "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #" + "Used for highlighting Tramp debug buffers in `outline-mode'.") + +(defun tramp-debug-outline-level () + "Return the depth to which a statement is nested in the outline. +Point must be at the beginning of a header line. + +The outline level is equal to the verbosity of the Tramp message." + (1+ (string-to-number (match-string 1)))) + +(defun tramp-get-debug-buffer (vec) + "Get the debug buffer for VEC." + (with-current-buffer + (get-buffer-create (tramp-debug-buffer-name vec)) + (when (bobp) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes + ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". + ;; Furthermore, `outline-regexp' must have the correct value + ;; already, because it is used by `font-lock-compile-keywords'. + (let ((default-directory (tramp-compat-temporary-file-directory)) + (outline-regexp tramp-debug-outline-regexp)) + (outline-mode)) + (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) + (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)) + (current-buffer))) + (defsubst tramp-debug-message (vec fmt-string &rest args) "Append message to debug buffer. Message is formatted with FMT-STRING as control string and the remaining @@ -2173,36 +1324,34 @@ Calls functions `message' and `tramp-debug-message' with FMT-STRING as control string and the remaining ARGS to actually emit the message (if applicable)." - (condition-case nil - (when (<= level tramp-verbose) - ;; Match data must be preserved! - (save-match-data - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) - (apply 'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - args)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - (when (and vec-or-proc - (processp vec-or-proc) - (buffer-name (process-buffer vec-or-proc))) - (with-current-buffer (process-buffer vec-or-proc) - ;; Translate proc to vec. - (setq vec-or-proc (tramp-dissect-file-name default-directory)))) - (when (and vec-or-proc (vectorp vec-or-proc)) - (apply 'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - args))))) - ;; Suppress all errors. - (error nil))) + (ignore-errors + (when (<= level tramp-verbose) + ;; Match data must be preserved! + (save-match-data + ;; Display only when there is a minimum level. + (when (and tramp-message-show-message (<= level 3)) + (apply 'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + args)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (when (and vec-or-proc + (processp vec-or-proc) + (buffer-name (process-buffer vec-or-proc))) + (with-current-buffer (process-buffer vec-or-proc) + ;; Translate proc to vec. + (setq vec-or-proc (tramp-dissect-file-name default-directory)))) + (when (and vec-or-proc (vectorp vec-or-proc)) + (apply 'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + args))))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest args) "Emit an error. @@ -2264,46 +1413,14 @@ (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) - -(defmacro with-file-property (vec file property &rest body) - "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. -FILE must be a local file name on a connection identified via VEC." - `(if (file-name-absolute-p ,file) - (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass @body as parameter to - ;; `tramp-set-file-property' because it mangles our - ;; debug messages. - (setq value (progn ,@body)) - (tramp-set-file-property ,vec ,file ,property value)) - value) - ,@body)) - -(put 'with-file-property 'lisp-indent-function 3) -(put 'with-file-property 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-file-property\\>")) - -(defmacro with-connection-property (key property &rest body) - "Check in Tramp for property PROPERTY, otherwise executes BODY and set." - `(let ((value (tramp-get-connection-property ,key ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass ,@body as parameter to - ;; `tramp-set-connection-property' because it mangles our debug - ;; messages. - (setq value (progn ,@body)) - (tramp-set-connection-property ,key ,property value)) - value)) - -(put 'with-connection-property 'lisp-indent-function 2) -(put 'with-connection-property 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-connection-property\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value) (let* ((parameters (cdr reporter)) (message (aref parameters 3))) (when (string-match message (or (current-message) "")) - (funcall 'progress-reporter-update reporter value)))) + (tramp-compat-funcall 'progress-reporter-update reporter value)))) (defmacro with-progress-reporter (vec level message &rest body) "Executes BODY, spinning a progress reporter with MESSAGE. @@ -2317,11 +1434,10 @@ (when (and tramp-message-show-message ;; Display only when there is a minimum level. (<= ,level (min tramp-verbose 3))) - (condition-case nil - (setq pr (tramp-compat-funcall 'make-progress-reporter ,message) - tm (when pr - (run-at-time 3 0.1 'tramp-progress-reporter-update pr))) - (error nil))) + (ignore-errors + (setq pr (tramp-compat-funcall 'make-progress-reporter ,message) + tm (when pr + (run-at-time 3 0.1 'tramp-progress-reporter-update pr))))) (unwind-protect ;; Execute the body. Unset `tramp-message-show-message' when ;; the timer object is created, in order to suppress @@ -2335,7 +1451,8 @@ (put 'with-progress-reporter 'lisp-indent-function 3) (put 'with-progress-reporter 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-progress-reporter\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-progress-reporter\\>")) (eval-and-compile ;; Silence compiler. (if (memq system-type '(cygwin windows-nt)) @@ -2352,34 +1469,6 @@ (defalias 'tramp-drop-volume-letter 'identity))) -(defsubst tramp-make-tramp-temp-file (vec) - "Create a temporary file on the remote host identified by VEC. -Return the local name of the temporary file." - (let ((prefix - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (tramp-drop-volume-letter - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) - result) - (while (not result) - ;; `make-temp-file' would be the natural choice for - ;; implementation. But it calls `write-region' internally, - ;; which also needs a temporary file - we would end in an - ;; infinite loop. - (setq result (make-temp-name prefix)) - (if (file-exists-p result) - (setq result nil) - ;; This creates the file by side effect. - (set-file-times result) - (set-file-modes result (tramp-octal-to-decimal "0700")))) - - ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) - - ;;; Config Manipulation Functions: (defun tramp-set-completion-function (method function-list) @@ -2414,7 +1503,7 @@ ;; Windows registry. (and (memq system-type '(cygwin windows-nt)) (zerop - (tramp-local-call-process + (tramp-compat-call-process "reg" nil nil nil "query" (nth 1 (car v))))) ;; Configuration file. (file-exists-p (nth 1 (car v))))) @@ -2502,279 +1591,6 @@ (remove-hook 'rfn-eshadow-update-overlay-hook 'tramp-rfn-eshadow-update-overlay)))) - -;;; Integration of eshell.el: - -(eval-when-compile - (defvar eshell-path-env)) - -;; eshell.el keeps the path in `eshell-path-env'. We must change it -;; when `default-directory' points to another host. -(defun tramp-eshell-directory-change () - "Set `eshell-path-env' to $PATH of the host related to `default-directory'." - (setq eshell-path-env - (if (file-remote-p default-directory) - (with-parsed-tramp-file-name default-directory nil - (mapconcat - 'identity - (tramp-get-remote-path v) - ":")) - (getenv "PATH")))) - -(eval-after-load "esh-util" - '(progn - (tramp-eshell-directory-change) - (add-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change))))) - - -;;; File Name Handler Functions: - -(defun tramp-handle-make-symbolic-link - (filename linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If LINKNAME is a non-Tramp file, it is used verbatim as the target of -the symlink. If LINKNAME is a Tramp file, only the localname component is -used as the target of the symlink. - -If LINKNAME is a Tramp file and the localname component is relative, then -it is expanded first, before the localname component is taken. Note that -this can give surprising results if the user/host for the source and -target of the symlink differ." - (with-parsed-tramp-file-name linkname l - (let ((ln (tramp-get-remote-ln l)) - (cwd (tramp-run-real-handler - 'file-name-directory (list l-localname)))) - (unless ln - (tramp-error - l 'file-error - "Making a symbolic link. ln(1) does not exist on the remote host.")) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - l-localname))))) - (tramp-error - l 'file-already-exists "File %s already exists" l-localname) - (delete-file linkname))) - - ;; If FILENAME is a Tramp name, use just the localname component. - (when (tramp-tramp-file-p filename) - (setq filename - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name filename))))) - - (tramp-flush-file-property l (file-name-directory l-localname)) - (tramp-flush-file-property l l-localname) - - ;; Right, they are on the same host, regardless of user, method, etc. - ;; We now make the link on the remote machine. This will occur as the user - ;; that FILENAME belongs to. - (zerop - (tramp-send-command-and-check - l - (format - "cd %s && %s -sf %s %s" - (tramp-shell-quote-argument cwd) - ln - (tramp-shell-quote-argument filename) - (tramp-shell-quote-argument l-localname)) - t))))) - -(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) - "Like `load' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name file) nil - (unless nosuffix - (cond ((file-exists-p (concat file ".elc")) - (setq file (concat file ".elc"))) - ((file-exists-p (concat file ".el")) - (setq file (concat file ".el"))))) - (when must-suffix - ;; The first condition is always true for absolute file names. - ;; Included for safety's sake. - (unless (or (file-name-directory file) - (string-match "\\.elc?\\'" file)) - (tramp-error - v 'file-error - "File `%s' does not include a `.el' or `.elc' suffix" file))) - (unless noerror - (when (not (file-exists-p file)) - (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file))) - (if (not (file-exists-p file)) - nil - (let ((tramp-message-show-message (not nomessage))) - (with-progress-reporter v 0 (format "Loading %s" file) - (let ((local-copy (file-local-copy file))) - ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. - (unwind-protect - (load local-copy noerror t t) - (delete-file local-copy))))) - t))) - -;; Localname manipulation functions that grok Tramp localnames... -(defun tramp-handle-file-name-as-directory (file) - "Like `file-name-as-directory' but aware of Tramp files." - ;; `file-name-as-directory' would be sufficient except localname is - ;; the empty string. - (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-host v) - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))))) - -(defun tramp-handle-file-name-directory (file) - "Like `file-name-directory' but aware of Tramp files." - ;; Everything except the last filename thing is the directory. We - ;; cannot apply `with-parsed-tramp-file-name', because this expands - ;; the remote file name parts. This is a problem when we are in - ;; file name completion. - (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-host v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) - -(defun tramp-handle-file-name-nondirectory (file) - "Like `file-name-nondirectory' but aware of Tramp files." - (with-parsed-tramp-file-name file nil - (tramp-run-real-handler 'file-name-nondirectory (list localname)))) - -(defun tramp-handle-file-truename (filename &optional counter prev-dirs) - "Like `file-truename' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-truename" - (let ((result nil)) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (setq result - (tramp-send-command-and-read - v - (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\"" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec" nil) - (tramp-get-connection-property v "perl-cwd-realpath" nil)) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (setq result - (tramp-send-command-and-read - v - (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname))))) - - ;; Do it yourself. We bind `directory-sep-char' here for - ;; XEmacs on Windows, which would otherwise use backslash. - (t (let* ((directory-sep-char ?/) - (steps (tramp-compat-split-string localname "/")) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) - (setq symlink-target - (nth 0 (file-attributes - (tramp-make-tramp-file-name - method user host - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string like - ;; "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (tramp-compat-split-string - symlink-target "/") - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (mapconcat 'identity (cons "" result) "/") - "/")) - (when (and is-dir (or (string= "" result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))))) - - (tramp-message v 4 "True name of `%s' is `%s'" filename result) - (tramp-make-tramp-file-name method user host result))))) - -;; Basic functions. - -(defun tramp-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-exists-p" - (or (not (null (tramp-get-file-property - v localname "file-attributes-integer" nil))) - (not (null (tramp-get-file-property - v localname "file-attributes-string" nil))) - (zerop (tramp-send-command-and-check - v - (format - "%s %s" - (tramp-get-file-exists-command v) - (tramp-shell-quote-argument localname)))))))) - ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method ;; applied might be not so efficient (Ange-FTP uses hashes). But @@ -2791,1638 +1607,12 @@ (defvar tramp-devices nil "Keeps virtual device numbers.") -;; CCC: This should check for an error condition and signal failure -;; when something goes wrong. -;; Daniel Pittman <daniel@danann.net> -(defun tramp-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t - (tramp-do-file-attributes-with-ls v localname id-format))))))))) - -(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using the ls(1) command." - (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) - (tramp-message vec 5 "file attributes with ls: %s" localname) - (tramp-send-command - vec - (format "(%s %s || %s -h %s) && %s %s %s" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - (if (eq id-format 'integer) "-ildn" "-ild") - (tramp-shell-quote-argument localname))) - ;; parse `ls -l' output ... - (with-current-buffer (tramp-get-buffer vec) - (when (> (buffer-size) 0) - (goto-char (point-min)) - ;; ... inode - (setq res-inode - (condition-case err - (read (current-buffer)) - (invalid-read-syntax - (when (and (equal (cadr err) - "Integer constant overflow in reader") - (string-match - "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'" - (car (cddr err)))) - (let* ((big (read (substring (car (cddr err)) 0 - (match-beginning 1)))) - (small (read (match-string 1 (car (cddr err))))) - (twiddle (/ small 65536))) - (cons (+ big twiddle) - (- small (* twiddle 65536)))))))) - ;; ... file mode flags - (setq res-filemodes (symbol-name (read (current-buffer)))) - ;; ... number links - (setq res-numlinks (read (current-buffer))) - ;; ... uid and gid - (setq res-uid (read (current-buffer))) - (setq res-gid (read (current-buffer))) - (if (eq id-format 'integer) - (progn - (unless (numberp res-uid) (setq res-uid -1)) - (unless (numberp res-gid) (setq res-gid -1))) - (progn - (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) - (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) - ;; ... size - (setq res-size (read (current-buffer))) - ;; From the file modes, figure out other stuff. - (setq symlinkp (eq ?l (aref res-filemodes 0))) - (setq dirp (eq ?d (aref res-filemodes 0))) - ;; if symlink, find out file name pointed to - (when symlinkp - (search-forward "-> ") - (setq res-symlink-target - (buffer-substring (point) (tramp-compat-line-end-position)))) - ;; return data gathered - (list - ;; 0. t for directory, string (name linked to) for symbolic - ;; link, or nil. - (or dirp res-symlink-target) - ;; 1. Number of links to file. - res-numlinks - ;; 2. File uid. - res-uid - ;; 3. File gid. - res-gid - ;; 4. Last access time, as a list of two integers. First - ;; integer has high-order 16 bits of time, second has low 16 - ;; bits. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - '(0 0) '(0 0) '(0 0) ;CCC how to find out? - ;; 7. Size in bytes (-1, if number is out of range). - res-size - ;; 8. File modes, as a string of ten letters or dashes as in ls -l. - res-filemodes - ;; 9. t if file's gid would change if file were deleted and - ;; recreated. Will be set in `tramp-convert-file-attributes' - t - ;; 10. inode number. - res-inode - ;; 11. Device number. Will be replaced by a virtual device number. - -1 - ))))) - -(defun tramp-do-file-attributes-with-perl - (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using a Perl script." - (tramp-message vec 5 "file attributes with perl: %s" localname) - (tramp-maybe-send-script - vec tramp-perl-file-attributes "tramp_perl_file_attributes") - (tramp-send-command-and-read - vec - (format "tramp_perl_file_attributes %s %s" - (tramp-shell-quote-argument localname) id-format))) - -(defun tramp-do-file-attributes-with-stat - (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using stat(1) command." - (tramp-message vec 5 "file attributes with stat: %s" localname) - (tramp-send-command-and-read - vec - (format - ;; On Opsware, pdksh (which is the true name of ksh there) doesn't - ;; parse correctly the sequence "((". Therefore, we add a space. - "( (%s %s || %s -h %s) && %s -c '( (\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s.0 \"%%A\" t %%i.0 -1)' %s || echo nil)" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"") - (tramp-shell-quote-argument localname)))) - -(defun tramp-handle-set-visited-file-modtime (&optional time-list) - "Like `set-visited-file-modtime' for Tramp files." - (unless (buffer-file-name) - (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" - (buffer-name))) - (if time-list - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) - (let ((f (buffer-file-name)) - coding-system-used) - (with-parsed-tramp-file-name f nil - (let* ((attr (file-attributes f)) - ;; '(-1 65535) means file doesn't exists yet. - (modtime (or (nth 5 attr) '(-1 65535)))) - (when (boundp 'last-coding-system-used) - (setq coding-system-used (symbol-value 'last-coding-system-used))) - ;; We use '(0 0) as a don't-know value. See also - ;; `tramp-do-file-attributes-with-ls'. - (if (not (equal modtime '(0 0))) - (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) - (progn - (tramp-send-command - v - (format "%s -ild %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))) - (setq attr (buffer-substring (point) - (progn (end-of-line) (point))))) - (tramp-set-file-property - v localname "visited-file-modtime-ild" attr)) - (when (boundp 'last-coding-system-used) - (set 'last-coding-system-used coding-system-used)) - nil))))) - -;; This function makes the same assumption as -;; `tramp-handle-set-visited-file-modtime'. -(defun tramp-handle-verify-visited-file-modtime (buf) - "Like `verify-visited-file-modtime' for Tramp files. -At the time `verify-visited-file-modtime' calls this function, we -already know that the buffer is visiting a file and that -`visited-file-modtime' does not return 0. Do not call this -function directly, unless those two cases are already taken care -of." - (with-current-buffer buf - (let ((f (buffer-file-name))) - ;; There is no file visiting the buffer, or the buffer has no - ;; recorded last modification time, or there is no established - ;; connection. - (if (or (not f) - (eq (visited-file-modtime) 0) - (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) - t - (with-parsed-tramp-file-name f nil - (tramp-flush-file-property v localname) - (let* ((attr (file-attributes f)) - (modtime (nth 5 attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr - (tramp-send-command - v - (format "%s -ild %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-buffer v) - (setq attr (buffer-substring - (point) (progn (end-of-line) (point))))) - (equal - attr - (tramp-get-file-property - v localname "visited-file-modtime-ild" ""))) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) - -(defun tramp-handle-set-file-modes (filename mode) - "Like `set-file-modes' for Tramp files." - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (unless (zerop (tramp-send-command-and-check - v - (format "chmod %s %s" - (tramp-decimal-to-octal mode) - (tramp-shell-quote-argument localname)))) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) - -(defun tramp-handle-set-file-times (filename &optional time) - "Like `set-file-times' for Tramp files." - (zerop - (if (file-remote-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time)) - ;; With GNU Emacs, `format-time-string' has an optional - ;; parameter UNIVERSAL. This is preferred, because we - ;; could handle the case when the remote host is - ;; located in a different time zone as the local host. - (utc (not (featurep 'xemacs)))) - (tramp-send-command-and-check - v (format "%s touch -t %s %s" - (if utc "TZ=UTC; export TZ;" "") - (if utc - (format-time-string "%Y%m%d%H%M.%S" time t) - (format-time-string "%Y%m%d%H%M.%S" time)) - (tramp-shell-quote-argument localname))))) - - ;; We handle also the local part, because in older Emacsen, - ;; without `set-file-times', this function is an alias for this. - ;; We are local, so we don't need the UTC settings. - (tramp-local-call-process - "touch" nil nil nil "-t" - (format-time-string "%Y%m%d%H%M.%S" time) - (tramp-shell-quote-argument filename))))) - -(defun tramp-set-file-uid-gid (filename &optional uid gid) - "Set the ownership for FILENAME. -If UID and GID are provided, these values are used; otherwise uid -and gid of the corresponding user is taken. Both parameters must be integers." - ;; Modern Unices allow chown only for root. So we might need - ;; another implementation, see `dired-do-chown'. OTOH, it is mostly - ;; working with su(do)? when it is needed, so it shall succeed in - ;; the majority of cases. - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (if (file-remote-p filename) - (with-parsed-tramp-file-name filename nil - (if (and (zerop (user-uid)) (tramp-local-host-p v)) - ;; If we are root on the local host, we can do it directly. - (tramp-set-file-uid-gid localname uid gid) - (let ((uid (or (and (integerp uid) uid) - (tramp-get-remote-uid v 'integer))) - (gid (or (and (integerp gid) gid) - (tramp-get-remote-gid v 'integer)))) - (tramp-send-command - v (format - "chown %d:%d %s" uid gid - (tramp-shell-quote-argument localname)))))) - - ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. On W32 "chown" might not work. - (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-local-call-process - "chown" nil nil nil - (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)))))) - -(defun tramp-remote-selinux-p (vec) - "Check, whether SELINUX is enabled on the remote host." - (with-connection-property (tramp-get-connection-process vec) "selinux-p" - (let ((result (tramp-find-executable - vec "getenforce" (tramp-get-remote-path vec) t t))) - (and result - (string-equal - (tramp-send-command-and-read - vec (format "echo \\\"`%S`\\\"" result)) - "Enforcing"))))) - -(defun tramp-handle-file-selinux-context (filename) - "Like `file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-selinux-context" - (let ((context '(nil nil nil nil)) - (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) - (when (and (tramp-remote-selinux-p v) - (zerop (tramp-send-command-and-check - v (format - "%s -d -Z %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (when (re-search-forward regexp (tramp-compat-line-end-position) t) - (setq context (list (match-string 1) (match-string 2) - (match-string 3) (match-string 4)))))) - ;; Return the context. - context)))) - -(defun tramp-handle-set-file-selinux-context (filename context) - "Like `set-file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil - (if (and (consp context) - (tramp-remote-selinux-p v) - (zerop (tramp-send-command-and-check - v (format "chcon %s %s %s %s %s" - (if (stringp (nth 0 context)) - (format "--user=%s" (nth 0 context)) "") - (if (stringp (nth 1 context)) - (format "--role=%s" (nth 1 context)) "") - (if (stringp (nth 2 context)) - (format "--type=%s" (nth 2 context)) "") - (if (stringp (nth 3 context)) - (format "--range=%s" (nth 3 context)) "") - (tramp-shell-quote-argument localname))))) - (tramp-set-file-property v localname "file-selinux-context" context) - (tramp-set-file-property v localname "file-selinux-context" 'undef))) - ;; We always return nil. - nil) - -;; Simple functions using the `test' command. - -(defun tramp-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-executable-p" - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?x) - (zerop (tramp-run-test "-x" filename)))))) - -(defun tramp-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-readable-p" - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?r) - (zerop (tramp-run-test "-r" filename)))))) - -;; When the remote shell is started, it looks for a shell which groks -;; tilde expansion. Here, we assume that all shells which grok tilde -;; expansion will also provide a `test' command which groks `-nt' (for -;; newer than). If this breaks, tell me about it and I'll try to do -;; something smarter about it. -(defun tramp-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) - nil) - ((not (file-exists-p file2)) - t) - ;; We are sure both files exist at this point. - (t - (save-excursion - ;; We try to get the mtime of both files. If they are not - ;; equal to the "dont-know" value, then we subtract the times - ;; and obtain the result. - (let ((fa1 (file-attributes file1)) - (fa2 (file-attributes file2))) - (if (and (not (equal (nth 5 fa1) '(0 0))) - (not (equal (nth 5 fa2) '(0 0)))) - (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1))) - ;; If one of them is the dont-know value, then we can - ;; still try to run a shell command on the remote host. - ;; However, this only works if both files are Tramp - ;; files and both have the same method, same user, same - ;; host. - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "Files %s and %s must have same method, user, host" - file1 file2))) - (with-parsed-tramp-file-name file1 nil - (zerop (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2))))))))) - -;; Functions implemented using the basic functions above. - -(defun tramp-handle-file-modes (filename) - "Like `file-modes' for Tramp files." - (let ((truename (or (file-truename filename) filename))) - (when (file-exists-p truename) - (tramp-mode-string-to-int (nth 8 (file-attributes truename)))))) - (defun tramp-default-file-modes (filename) "Return file modes of FILENAME as integer. If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." (or (file-modes filename) - (logand (default-file-modes) (tramp-octal-to-decimal "0666")))) - -(defun tramp-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - ;; Care must be taken that this function returns `t' for symlinks - ;; pointing to directories. Surely the most obvious implementation - ;; would be `test -d', but that returns false for such symlinks. - ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And - ;; I now think he's right. So we could be using `test -d', couldn't - ;; we? - ;; - ;; Alternatives: `cd %s', `test -d %s' - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-directory-p" - (zerop (tramp-run-test "-d" filename))))) - -(defun tramp-handle-file-regular-p (filename) - "Like `file-regular-p' for Tramp files." - (and (file-exists-p filename) - (eq ?- (aref (nth 8 (file-attributes filename)) 0)))) - -(defun tramp-handle-file-symlink-p (filename) - "Like `file-symlink-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (let ((x (car (file-attributes filename)))) - (when (stringp x) - ;; When Tramp is running on VMS, then `file-name-absolute-p' - ;; might do weird things. - (if (file-name-absolute-p x) - (tramp-make-tramp-file-name method user host x) - x))))) - -(defun tramp-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-writable-p" - (if (file-exists-p filename) - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?w) - (zerop (tramp-run-test "-w" filename))) - ;; If file doesn't exist, check if directory is writable. - (and (zerop (tramp-run-test - "-d" (file-name-directory filename))) - (zerop (tramp-run-test - "-w" (file-name-directory filename)))))))) - -(defun tramp-handle-file-ownership-preserved-p (filename) - "Like `file-ownership-preserved-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) - ;; Return t if the file doesn't exist, since it's true that no - ;; information would be lost by an (attempted) delete and create. - (or (null attributes) - (= (nth 2 attributes) (tramp-get-remote-uid v 'integer))))))) - -;; Other file name ops. - -(defun tramp-handle-directory-file-name (directory) - "Like `directory-file-name' for Tramp files." - ;; If localname component of filename is "/", leave it unchanged. - ;; Otherwise, remove any trailing slash from localname component. - ;; Method, host, etc, are unchanged. Does it make sense to try - ;; to avoid parsing the filename? - (with-parsed-tramp-file-name directory nil - (if (and (not (zerop (length localname))) - (eq (aref localname (1- (length localname))) ?/) - (not (string= localname "/"))) - (substring directory 0 -1) - directory))) - -;; Directory listings. - -(defun tramp-handle-directory-files - (directory &optional full match nosort files-only) - "Like `directory-files' for Tramp files." - ;; FILES-ONLY is valid for XEmacs only. - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let ((temp (nreverse (file-name-all-completions "" directory))) - result item) - - (while temp - (setq item (directory-file-name (pop temp))) - (when (and (or (null match) (string-match match item)) - (or (null files-only) - ;; Files only. - (and (equal files-only t) (file-regular-p item)) - ;; Directories only. - (file-directory-p item))) - (push (if full (concat directory item) item) - result))) - (if nosort result (sort result 'string<))))) - -(defun tramp-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (when (file-directory-p directory) - (setq directory (expand-file-name directory)) - (let* ((temp - (copy-tree - (with-parsed-tramp-file-name directory nil - (with-file-property - v localname - (format "directory-files-and-attributes-%s" id-format) - (save-excursion - (mapcar - (lambda (x) - (cons (car x) - (tramp-convert-file-attributes v (cdr x)))) - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format))))))))) - result item) - - (while temp - (setq item (pop temp)) - (when (or (null match) (string-match match (car item))) - (when full - (setcar item (expand-file-name (car item) directory))) - (push item result))) - - (if nosort - result - (sort result (lambda (x y) (string< (car x) (car y)))))))) - -(defun tramp-do-directory-files-and-attributes-with-perl - (vec localname &optional id-format) - "Implement `directory-files-and-attributes' for Tramp files using a Perl script." - (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) - (tramp-maybe-send-script - vec tramp-perl-directory-files-and-attributes - "tramp_perl_directory_files_and_attributes") - (let ((object - (tramp-send-command-and-read - vec - (format "tramp_perl_directory_files_and_attributes %s %s" - (tramp-shell-quote-argument localname) id-format)))) - (when (stringp object) (tramp-error vec 'file-error object)) - object)) - -(defun tramp-do-directory-files-and-attributes-with-stat - (vec localname &optional id-format) - "Implement `directory-files-and-attributes' for Tramp files using stat(1) command." - (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) - (tramp-send-command-and-read - vec - (format - (concat - ;; We must care about filenames with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Therefore, we - ;; quote the filenames via sed. - "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs " - "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s.0 \"%%A\" t %%i.0 -1)'); " - "echo \")\"") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"")))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) - (with-parsed-tramp-file-name (expand-file-name directory) nil - - (all-completions - filename - (mapcar - 'list - (or - ;; Try cache first - (and - ;; Ignore if expired - (or (not (integerp tramp-completion-reread-directory-timeout)) - (<= (tramp-time-diff - (current-time) - (tramp-get-file-property - v localname "last-completion" '(0 0 0))) - tramp-completion-reread-directory-timeout)) - - ;; Try cache entries for filename, filename with last - ;; character removed, filename with last two characters - ;; removed, ..., and finally the empty string - all - ;; concatenated to the local directory name - - ;; This is inefficient for very long filenames, pity - ;; `reduce' is not available... - (car - (apply - 'append - (mapcar - (lambda (x) - (let ((cache-hit - (tramp-get-file-property - v - (concat localname (substring filename 0 x)) - "file-name-all-completions" - nil))) - (when cache-hit (list cache-hit)))) - (tramp-compat-number-sequence (length filename) 0 -1))))) - - ;; Cache expired or no matching cache entry found so we need - ;; to perform a remote operation - (let (result) - ;; Get a list of directories and files, including reliably - ;; tagging the directories with a trailing '/'. Because I - ;; rock. --daniel@danann.net - - ;; Changed to perform `cd' in the same remote op and only - ;; get entries starting with `filename'. Capture any `cd' - ;; error messages. Ensure any `cd' and `echo' aliases are - ;; ignored. - (tramp-send-command - v - (if (tramp-get-remote-perl v) - (progn - (tramp-maybe-send-script - v tramp-perl-file-name-all-completions - "tramp_perl_file_name_all_completions") - (format "tramp_perl_file_name_all_completions %s %s %d" - (tramp-shell-quote-argument localname) - (tramp-shell-quote-argument filename) - (if (symbol-value - ;; `read-file-name-completion-ignore-case' - ;; is introduced with Emacs 22.1. - (if (boundp - 'read-file-name-completion-ignore-case) - 'read-file-name-completion-ignore-case - 'completion-ignore-case)) - 1 0))) - - (format (concat - "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null" - ;; `ls' with wildcard might fail with `Argument - ;; list too long' error in some corner cases; if - ;; `ls' fails after `cd' succeeded, chances are - ;; that's the case, so let's retry without - ;; wildcard. This will return "too many" entries - ;; but that isn't harmful. - " || %s -a 2>/dev/null)" - " | while read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command v) - ;; When `filename' is empty, just `ls' without - ;; filename argument is more efficient than `ls *' - ;; for very large directories and might avoid the - ;; `Argument list too long' error. - ;; - ;; With and only with wildcard, we need to add - ;; `-d' to prevent `ls' from descending into - ;; sub-directories. - (if (zerop (length filename)) - "." - (concat (tramp-shell-quote-argument filename) "* -d")) - (tramp-get-ls-command v) - (tramp-get-test-command v)))) - - ;; Now grab the output. - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-max)) - - ;; Check result code, found in last line of output - (forward-line -1) - (if (looking-at "^fail$") - (progn - ;; Grab error message from line before last line - ;; (it was put there by `cd 2>&1') - (forward-line -1) - (tramp-error - v 'file-error - "tramp-handle-file-name-all-completions: %s" - (buffer-substring - (point) (tramp-compat-line-end-position)))) - ;; For peace of mind, if buffer doesn't end in `fail' - ;; then it should end in `ok'. If neither are in the - ;; buffer something went seriously wrong on the remote - ;; side. - (unless (looking-at "^ok$") - (tramp-error - v 'file-error - "\ -tramp-handle-file-name-all-completions: internal error accessing `%s': `%s'" - (tramp-shell-quote-argument localname) (buffer-string)))) - - (while (zerop (forward-line -1)) - (push (buffer-substring - (point) (tramp-compat-line-end-position)) - result))) - - ;; Because the remote op went through OK we know the - ;; directory we `cd'-ed to exists - (tramp-set-file-property - v localname "file-exists-p" t) - - ;; Because the remote op went through OK we know every - ;; file listed by `ls' exists. - (mapc (lambda (entry) - (tramp-set-file-property - v (concat localname entry) "file-exists-p" t)) - result) - - (tramp-set-file-property - v localname "last-completion" (current-time)) - - ;; Store result in the cache - (tramp-set-file-property - v (concat localname filename) - "file-name-all-completions" - result)))))))) - -(defun tramp-handle-file-name-completion - (filename directory &optional predicate) - "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) - (try-completion - filename - (mapcar 'list (file-name-all-completions filename directory)) - (when predicate - (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) - -;; cp, mv and ln - -(defun tramp-handle-add-name-to-file - (filename newname &optional ok-if-already-exists) - "Like `add-name-to-file' for Tramp files." - (unless (tramp-equal-remote filename newname) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - (tramp-error - v 'file-error - "add-name-to-file: %s" - "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (let ((ln (when v1 (tramp-get-remote-ln v1)))) - (when (and (not ok-if-already-exists) - (file-exists-p newname) - (not (numberp ok-if-already-exists)) - (y-or-n-p - (format - "File %s already exists; make it a new name anyway? " - newname))) - (tramp-error - v2 'file-error - "add-name-to-file: file %s already exists" newname)) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) - (tramp-barf-unless-okay - v1 - (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)) - "error with add-name-to-file, see buffer `%s' for details" - (buffer-name)))))) - -(defun tramp-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (cond - ;; At least one file a Tramp file? - ((or (tramp-tramp-file-p filename) - (tramp-tramp-file-p newname)) - (tramp-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context)) - ;; Compat section. - (preserve-selinux-context - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context))) - (preserve-uid-gid - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) - (t - (tramp-run-real-handler - 'copy-file (list filename newname ok-if-already-exists keep-date))))) - -(defun tramp-handle-copy-directory (dirname newname &optional keep-date parents) - "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must have - ;; the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (if (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (if (not (file-directory-p (file-name-directory newname))) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) - ;; We must do it file-wise. - (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) - -(defun tramp-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - ;; Check if both files are local -- invoke normal rename-file. - ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - ;; At least one file a Tramp file? - (if (or (tramp-tramp-file-p filename) - (tramp-tramp-file-p newname)) - (tramp-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t) - (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) - -(defun tramp-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to perform. -FILENAME specifies the file to copy or rename, NEWNAME is the name of -the new file (for copy) or the new name of the file (for rename). -OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid if both files are on the same host. -PRESERVE-SELINUX-CONTEXT activates selinux commands. - -This function is invoked by `tramp-handle-copy-file' and -`tramp-handle-rename-file'. It is an error if OP is neither of `copy' -and `rename'. FILENAME and NEWNAME must be absolute file names." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (context (and preserve-selinux-context - (apply 'file-selinux-context (list filename)))) - pr tm) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (with-progress-reporter - v 0 (format "%s %s to %s" - (if (eq op 'copy) "Copying" "Renaming") - filename newname) - - (cond - ;; Both are Tramp files. - ((and t1 t2) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (cond - ;; Shortcut: if method, host, user are the same for - ;; both files, we invoke `cp' or `mv' on the remote - ;; host directly. - ((tramp-equal-remote filename newname) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; Try out-of-band operation. - ((tramp-method-out-of-band-p - v1 (nth 7 (file-attributes filename))) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) - - ;; No shortcut was possible. So we copy the file - ;; first. If the operation was `rename', we go back - ;; and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which filename handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) - (cond - ;; Fast track on local machine. - ((tramp-local-host-p v) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; If the Tramp file has an out-of-band method, the - ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p v (nth 7 (file-attributes filename))) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) - - ;; Use the inline method via a Tramp buffer. - (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - - ;; Handle `preserve-selinux-context'. - (when context (apply 'set-file-selinux-context (list newname context))) - - ;; In case of `rename', we must flush the cache of the source file. - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory localname)) - (tramp-flush-file-property v1 localname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory localname)) - (tramp-flush-file-property v2 localname))))))) - -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) - "Use an Emacs buffer to copy or rename a file. -First arg OP is either `copy' or `rename' and indicates the operation. -FILENAME is the source file, NEWNAME the target file. -KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." - (with-temp-buffer - ;; We must disable multibyte, because binary data shall not be - ;; converted. - (set-buffer-multibyte nil) - (let ((coding-system-for-read 'binary) - (jka-compr-inhibit t)) - (insert-file-contents-literally filename)) - ;; We don't want the target file to be compressed, so we let-bind - ;; `jka-compr-inhibit' to t. - (let ((coding-system-for-write 'binary) - (jka-compr-inhibit t)) - (write-region (point-min) (point-max) newname))) - ;; KEEP-DATE handling. - (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))) - ;; Set the mode. - (set-file-modes newname (tramp-default-file-modes filename)) - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) (delete-file filename))) - -(defun tramp-do-copy-or-rename-file-directly - (op filename newname ok-if-already-exists keep-date preserve-uid-gid) - "Invokes `cp' or `mv' on the remote system. -OP must be one of `copy' or `rename', indicating `cp' or `mv', -respectively. FILENAME specifies the file to copy or rename, -NEWNAME is the name of the new file (for copy) or the new name of -the file (for rename). Both files must reside on the same host. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid from FILENAME." - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (file-times (nth 5 (file-attributes filename))) - (file-modes (tramp-default-file-modes filename))) - (with-parsed-tramp-file-name (if t1 filename newname) nil - (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") - ((eq op 'copy) "cp -f") - ((eq op 'rename) "mv -f") - (t (tramp-error - v 'file-error - "Unknown operation `%s', must be `copy' or `rename'" - op)))) - (localname1 - (if t1 - (tramp-file-name-handler 'file-remote-p filename 'localname) - filename)) - (localname2 - (if t2 - (tramp-file-name-handler 'file-remote-p newname 'localname) - newname)) - (prefix (file-remote-p (if t1 filename newname))) - cmd-result) - - (cond - ;; Both files are on a remote host, with same user. - ((and t1 t2) - (setq cmd-result - (tramp-send-command-and-check - v - (format "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument localname2)))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (unless - (or - (and keep-date - ;; Mask cp -f error. - (re-search-forward - tramp-operation-not-permitted-regexp nil t)) - (zerop cmd-result)) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (buffer-name))))) - - ;; We are on the local host. - ((or t1 t2) - (cond - ;; We can do it directly. - ((let (file-name-handler-alist) - (and (file-readable-p localname1) - (file-writable-p (file-name-directory localname2)) - (or (file-directory-p localname2) - (file-writable-p localname2)))) - (if (eq op 'copy) - (tramp-compat-copy-file - localname1 localname2 ok-if-already-exists - keep-date preserve-uid-gid) - (tramp-run-real-handler - 'rename-file (list localname1 localname2 ok-if-already-exists)))) - - ;; We can do it directly with `tramp-send-command' - ((and (file-readable-p (concat prefix localname1)) - (file-writable-p - (file-name-directory (concat prefix localname2))) - (or (file-directory-p (concat prefix localname2)) - (file-writable-p (concat prefix localname2)))) - (tramp-do-copy-or-rename-file-directly - op (concat prefix localname1) (concat prefix localname2) - ok-if-already-exists keep-date t) - ;; We must change the ownership to the local user. - (tramp-set-file-uid-gid - (concat prefix localname2) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - - ;; We need a temporary file in between. - (t - ;; Create the temporary file. - (let ((tmpfile (tramp-compat-make-temp-file localname1))) - (unwind-protect - (progn - (cond - (t1 - (or - (zerop - (tramp-send-command-and-check - v (format - "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument tmpfile)))) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (tramp-get-buffer v))) - ;; We must change the ownership as remote user. - ;; Since this does not work reliable, we also - ;; give read permissions. - (set-file-modes - (concat prefix tmpfile) (tramp-octal-to-decimal "0777")) - (tramp-set-file-uid-gid - (concat prefix tmpfile) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - (t2 - (if (eq op 'copy) - (tramp-compat-copy-file - localname1 tmpfile t - keep-date preserve-uid-gid) - (tramp-run-real-handler - 'rename-file - (list localname1 tmpfile t))) - ;; We must change the ownership as local user. - ;; Since this does not work reliable, we also - ;; give read permissions. - (set-file-modes tmpfile (tramp-octal-to-decimal "0777")) - (tramp-set-file-uid-gid - tmpfile - (tramp-get-remote-uid v 'integer) - (tramp-get-remote-gid v 'integer)))) - - ;; Move the temporary file to its destination. - (cond - (t2 - (or - (zerop - (tramp-send-command-and-check - v (format - "cp -f -p %s %s" - (tramp-shell-quote-argument tmpfile) - (tramp-shell-quote-argument localname2)))) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (tramp-get-buffer v)))) - (t1 - (tramp-run-real-handler - 'rename-file - (list tmpfile localname2 ok-if-already-exists))))) - - ;; Save exit. - (condition-case nil - (delete-file tmpfile) - (error))))))))) - - ;; Set the time and mode. Mask possible errors. - (condition-case nil - (when keep-date - (set-file-times newname file-times) - (set-file-modes newname file-modes)) - (error))))) - -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) - "Invoke rcp program to copy. -The method used must be an out-of-band method." - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - copy-program copy-args copy-env copy-keep-date port spec - source target) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (if (and t1 t2) - - ;; Both are Tramp files. We shall optimize it, when the - ;; methods for filename and newname are the same. - (let* ((dir-flag (file-directory-p filename)) - (tmpfile (tramp-compat-make-temp-file localname dir-flag))) - (if dir-flag - (setq tmpfile - (expand-file-name - (file-name-nondirectory newname) tmpfile))) - (unwind-protect - (progn - (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) - (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) - ;; Save exit. - (condition-case nil - (if dir-flag - (tramp-compat-delete-directory - (expand-file-name ".." tmpfile) 'recursive) - (delete-file tmpfile)) - (error)))) - - ;; Expand hops. Might be necessary for gateway methods. - (setq v (car (tramp-compute-multi-hops v))) - (aset v 3 localname) - - ;; Check which ones of source and target are Tramp files. - (setq source (if t1 (tramp-make-copy-program-file-name v) filename) - target (funcall - (if (and (file-directory-p filename) - (string-equal - (file-name-nondirectory filename) - (file-name-nondirectory newname))) - 'file-name-directory - 'identity) - (if t2 (tramp-make-copy-program-file-name v) newname))) - - ;; Check for port number. Until now, there's no need for handling - ;; like method, user, host. - (setq host (tramp-file-name-real-host v) - port (tramp-file-name-port v) - port (or (and port (number-to-string port)) "")) - - ;; Compose copy command. - (setq spec (format-spec-make - ?h host ?u user ?p port - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" "") - ?k (if keep-date " " "")) - copy-program (tramp-get-method-parameter - method 'tramp-copy-program) - copy-keep-date (tramp-get-method-parameter - method 'tramp-copy-keep-date) - copy-args - (delq - nil - (mapcar - (lambda (x) - (setq - x - ;; " " is indication for keep-date argument. - (delete " " (mapcar (lambda (y) (format-spec y spec)) x))) - (unless (member "" x) (mapconcat 'identity x " "))) - (tramp-get-method-parameter method 'tramp-copy-args))) - copy-env - (delq - nil - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) - (tramp-get-method-parameter method 'tramp-copy-env)))) - - ;; Check for program. - (when (and (fboundp 'executable-find) - (not (let ((default-directory - (tramp-compat-temporary-file-directory))) - (executable-find copy-program)))) - (tramp-error - v 'file-error "Cannot find copy program: %s" copy-program)) - - ;; Set variables for computing the prompt for reading - ;; password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (tramp-file-name-user v) - tramp-current-host (tramp-file-name-host v)) - - (unwind-protect - (with-temp-buffer - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - (while copy-env - (tramp-message v 5 "%s=\"%s\"" (car copy-env) (cadr copy-env)) - (setenv (pop copy-env) (pop copy-env))) - - ;; Use an asynchronous process. By this, password can - ;; be handled. The default directory must be local, in - ;; order to apply the correct `copy-program'. We don't - ;; set a timeout, because the copying of large files can - ;; last longer than 60 secs. - (let ((p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (apply 'start-process - (tramp-get-connection-property - v "process-name" nil) - (tramp-get-connection-property - v "process-buffer" nil) - copy-program - (append copy-args (list source target)))))) - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-process-query-on-exit-flag p nil) - (tramp-process-actions p v tramp-actions-copy-out-of-band)))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)) - - ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date)) - (set-file-times newname (nth 5 (file-attributes filename)))) - - ;; Set the mode. - (unless (and keep-date copy-keep-date) - (ignore-errors - (set-file-modes newname (tramp-default-file-modes filename))))) - - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) - (if (file-regular-p filename) - (delete-file filename) - (tramp-compat-delete-directory filename 'recursive)))))) - -(defun tramp-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) - (save-excursion - (tramp-barf-unless-okay - v - (format "%s %s" - (if parents "mkdir -p" "mkdir") - (tramp-shell-quote-argument localname)) - "Couldn't make directory %s" dir)))) - -(defun tramp-handle-delete-directory (directory &optional recursive) - "Like `delete-directory' for Tramp files." - (setq directory (expand-file-name directory)) - (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) - (unless (zerop (tramp-send-command-and-check - v - (format - "%s %s" - (if recursive "rm -rf" "rmdir") - (tramp-shell-quote-argument localname)))) - (tramp-error v 'file-error "Couldn't delete %s" directory)))) - -(defun tramp-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (unless - (zerop - (tramp-send-command-and-check - v (format "%s %s" - (or (and trash (tramp-get-remote-trash v)) "rm -f") - (tramp-shell-quote-argument localname)))) - (tramp-error v 'file-error "Couldn't delete %s" filename)))) - -;; Dired. - -;; CCC: This does not seem to be enough. Something dies when -;; we try and delete two directories under Tramp :/ -(defun tramp-handle-dired-recursive-delete-directory (filename) - "Recursively delete the directory given. -This is like `dired-recursive-delete-directory' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; Run a shell command 'rm -r <localname>' - ;; Code shamelessly stolen from the dired implementation and, um, hacked :) - (unless (file-exists-p filename) - (tramp-error v 'file-error "No such directory: %s" filename)) - ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>) - (tramp-send-command - v - (format "rm -rf %s" (tramp-shell-quote-argument localname)) - ;; Don't read the output, do it explicitely. - nil t) - ;; Wait for the remote system to return to us... - ;; This might take a while, allow it plenty of time. - (tramp-wait-for-output (tramp-get-connection-process v) 120) - ;; Make sure that it worked... - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) - (and (file-exists-p filename) - (tramp-error - v 'file-error "Failed to recursively delete %s" filename)))) - -(defun tramp-handle-dired-compress-file (file &rest ok-flag) - "Like `dired-compress-file' for Tramp files." - ;; OK-FLAG is valid for XEmacs only, but not implemented. - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) - (save-excursion - (let ((suffixes - (if (not (featurep 'xemacs)) - ;; Emacs case - (symbol-value 'dired-compress-file-suffixes) - ;; XEmacs has `dired-compression-method-alist', which is - ;; transformed into `dired-compress-file-suffixes' structure. - (mapcar - (lambda (x) - (list (concat (regexp-quote (nth 1 x)) "\\'") - nil - (mapconcat 'identity (nth 3 x) " "))) - (symbol-value 'dired-compression-method-alist)))) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) - nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-progress-reporter v 0 (format "Uncompressing %s" file) - (when (zerop - (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname)))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-progress-reporter v 0 (format "Compressing %s" file) - (when (zerop - (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname)))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil)))))))))) - -(defun tramp-handle-dired-uncache (dir &optional dir-p) - "Like `dired-uncache' for Tramp files." - ;; DIR-P is valid for XEmacs only. - (with-parsed-tramp-file-name - (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) - -;; Pacify byte-compiler. The function is needed on XEmacs only. I'm -;; not sure at all that this is the right way to do it, but let's hope -;; it works for now, and wait for a guru to point out the Right Way to -;; achieve this. -;;(eval-when-compile -;; (unless (fboundp 'dired-insert-set-properties) -;; (fset 'dired-insert-set-properties 'ignore))) -;; Gerd suggests this: -(eval-when-compile (require 'dired)) -;; Note that dired is required at run-time, too, when it is needed. -;; It is only needed on XEmacs for the function -;; `dired-insert-set-properties'. - -(defun tramp-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (if (and (featurep 'ls-lisp) - (not (symbol-value 'ls-lisp-use-insert-directory-program))) - (tramp-run-real-handler - 'insert-directory (list filename switches wildcard full-directory-p)) - (when (stringp switches) - (setq switches (split-string switches))) - (when (and (member "--dired" switches) - (not (tramp-get-ls-command-with-dired v))) - (setq switches (delete "--dired" switches))) - (when wildcard - (setq wildcard (tramp-run-real-handler - 'file-name-nondirectory (list localname))) - (setq localname (tramp-run-real-handler - 'file-name-directory (list localname)))) - (unless full-directory-p - (setq switches (add-to-list 'switches "-d" 'append))) - (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) - (when wildcard - (setq switches (concat switches " " wildcard))) - (tramp-message - v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s" - switches filename (if wildcard "yes" "no") - (if full-directory-p "yes" "no")) - ;; If `full-directory-p', we just say `ls -l FILENAME'. - ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. - (if full-directory-p - (tramp-send-command - v - (format "%s %s %s 2>/dev/null" - (tramp-get-ls-command v) - switches - (if wildcard - localname - (tramp-shell-quote-argument (concat localname "."))))) - (tramp-barf-unless-okay - v - (format "cd %s" (tramp-shell-quote-argument - (tramp-run-real-handler - 'file-name-directory (list localname)))) - "Couldn't `cd %s'" - (tramp-shell-quote-argument - (tramp-run-real-handler 'file-name-directory (list localname)))) - (tramp-send-command - v - (format "%s %s %s" - (tramp-get-ls-command v) - switches - (if (or wildcard - (zerop (length - (tramp-run-real-handler - 'file-name-nondirectory (list localname))))) - "" - (tramp-shell-quote-argument - (tramp-run-real-handler - 'file-name-nondirectory (list localname))))))) - (let ((beg (point))) - ;; We cannot use `insert-buffer-substring' because the Tramp - ;; buffer changes its contents before insertion due to calling - ;; `expand-file' and alike. - (insert - (with-current-buffer (tramp-get-buffer v) - (buffer-string))) - - ;; Check for "--dired" output. - (forward-line -2) - (when (looking-at "//SUBDIRED//") - (forward-line -1)) - (when (looking-at "//DIRED//\\s-+") - (let ((databeg (match-end 0)) - (end (tramp-compat-line-end-position))) - ;; Now read the numeric positions of file names. - (goto-char databeg) - (while (< (point) end) - (let ((start (+ beg (read (current-buffer)))) - (end (+ beg (read (current-buffer))))) - (if (memq (char-after end) '(?\n ?\ )) - ;; End is followed by \n or by " -> ". - (put-text-property start end 'dired-filename t)))))) - ;; Remove trailing lines. - (goto-char (tramp-compat-line-beginning-position)) - (while (looking-at "//") - (forward-line 1) - (delete-region (match-beginning 0) (point))) - - ;; The inserted file could be from somewhere else. - (when (and (not wildcard) (not full-directory-p)) - (goto-char (point-max)) - (when (file-symlink-p filename) - (goto-char (search-backward "->" beg 'noerror))) - (search-backward - (if (zerop (length (file-name-nondirectory filename))) - "." - (file-name-nondirectory filename)) - beg 'noerror) - (replace-match (file-relative-name filename) t)) - - (goto-char (point-max)))))) - -(defun tramp-handle-unhandled-file-name-directory (filename) - "Like `unhandled-file-name-directory' for Tramp files." - ;; With Emacs 23, we could simply return `nil'. But we must keep it - ;; for backward compatibility. - (expand-file-name "~/")) - -;; Canonicalization of file names. - -(defun tramp-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files. -If the localname part of the given filename starts with \"/../\" then -the result will be a local, non-Tramp, filename." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "~/" localname))) - ;; Tilde expansion if necessary. This needs a shell which - ;; groks tilde expansion! The function `tramp-find-shell' is - ;; supposed to find such a shell on the remote host. Please - ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot simply apply "~/", because under sudo "~/" is - ;; expanded to the local user home directory but to the - ;; root home directory. On the other hand, using always - ;; the default user name for tilde expansion is not - ;; appropriate either, because ssh and companions might - ;; use a user name from the config file. - (when (and (string-equal uname "~") - (string-match "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-connection-property v uname - (tramp-send-command - v (format "cd %s; pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring - (point) (tramp-compat-line-end-position))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). We bind - ;; `directory-sep-char' here for XEmacs on Windows, which would - ;; otherwise use backslash. `default-directory' is bound, - ;; because on Windows there would be problems with UNC shares or - ;; Cygwin mounts. - (let ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) + (logand (default-file-modes) (tramp-compat-octal-to-decimal "0666")))) (defun tramp-replace-environment-variables (filename) "Replace environment variables in FILENAME. @@ -4439,38 +1629,6 @@ t nil filename))) filename))) -(defun tramp-handle-substitute-in-file-name (filename) - "Like `substitute-in-file-name' for Tramp files. -\"//\" and \"/~\" substitute only in the local filename part. -If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at -beginning of local filename are not substituted." - ;; First, we must replace environment variables. - (setq filename (tramp-replace-environment-variables filename)) - (with-parsed-tramp-file-name filename nil - (if (equal tramp-syntax 'url) - ;; We need to check localname only. The other parts cannot contain - ;; "//" or "/~". - (if (and (> (length localname) 1) - (or (string-match "//" localname) - (string-match "/~" localname 1))) - (tramp-run-real-handler 'substitute-in-file-name (list filename)) - (tramp-make-tramp-file-name - (when method (substitute-in-file-name method)) - (when user (substitute-in-file-name user)) - (when host (substitute-in-file-name host)) - (when localname - (tramp-run-real-handler - 'substitute-in-file-name (list localname))))) - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) - (tramp-run-real-handler 'substitute-in-file-name (list filename))))) - ;; In XEmacs, electricity is implemented via a key map for ?/ and ?~, ;; which calls corresponding functions (see minibuf.el). (when (fboundp 'minibuffer-electric-separator) @@ -4500,406 +1658,9 @@ '(minibuffer-electric-separator minibuffer-electric-tilde))) - -;;; Remote commands: - -(defun tramp-handle-executable-find (command) - "Like `executable-find' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - (tramp-find-executable v command (tramp-get-remote-path v) t))) - -(defun tramp-process-sentinel (proc event) - "Flush file caches." - (unless (memq (process-status proc) '(run open)) - (let ((vec (tramp-get-connection-property proc "vector" nil))) - (when vec - (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event) - (tramp-flush-directory-property vec ""))))) - -;; We use BUFFER also as connection buffer during setup. Because of -;; this, its original contents must be saved, and restored once -;; connection has been setup. -(defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - (unwind-protect - ;; When PROGRAM is nil, we just provide a tty. - (let ((command - (when (stringp program) - (format "cd %s; exec %s" - (tramp-shell-quote-argument localname) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (name1 name) - (i 0)) - (unless buffer - ;; BUFFER can be nil. We use a temporary buffer. - (setq buffer (generate-new-buffer tramp-temp-buffer-name))) - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - ;; Activate narrowing in order to save BUFFER contents. - ;; Clear also the modification time; otherwise we might be - ;; interrupted by `verify-visited-file-modtime'. - (with-current-buffer (tramp-get-connection-buffer v) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max))) - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (tramp-maybe-open-connection v) - (unless (process-get (tramp-get-connection-process v) 'remote-tty) - (tramp-error - v 'file-error "pty association is not supported for `%s'" name))) - (let ((p (tramp-get-connection-process v))) - ;; Set sentinel and query flag for this process. - (tramp-set-connection-property p "vector" v) - (set-process-sentinel p 'tramp-process-sentinel) - (tramp-set-process-query-on-exit-flag p t) - ;; Return process. - p)) - ;; Save exit. - (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match tramp-temp-buffer-name (buffer-name)) - (progn - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (widen) - (goto-char (point-max)))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))) - -(defun tramp-handle-process-file - (program &optional infile destination display &rest args) - "Like `process-file' for Tramp files." - ;; The implementation is not complete yet. - (when (and (numberp destination) (zerop destination)) - (error "Implementation does not handle immediate return")) - - (with-parsed-tramp-file-name default-directory nil - (let (command input tmpinput stderr tmpstderr outbuf ret) - ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")) - ;; Determine input. - (if (null infile) - (setq input "/dev/null") - (setq infile (expand-file-name infile)) - (if (tramp-equal-remote default-directory infile) - ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) - ;; INFILE must be copied to remote host. - (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name method user host input)) - (copy-file infile tmpinput t))) - (when input (setq command (format "%s <%s" command input))) - - ;; Determine output. - (cond - ;; Just a buffer. - ((bufferp destination) - (setq outbuf destination)) - ;; A buffer name. - ((stringp destination) - (setq outbuf (get-buffer-create destination))) - ;; (REAL-DESTINATION ERROR-DESTINATION) - ((consp destination) - ;; output. - (cond - ((bufferp (car destination)) - (setq outbuf (car destination))) - ((stringp (car destination)) - (setq outbuf (get-buffer-create (car destination)))) - ((car destination) - (setq outbuf (current-buffer)))) - ;; stderr. - (cond - ((stringp (cadr destination)) - (setcar (cdr destination) (expand-file-name (cadr destination))) - (if (tramp-equal-remote default-directory (cadr destination)) - ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) - ;; stderr must be copied to remote host. The temporary - ;; file must be deleted after execution. - (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user host stderr)))) - ;; stderr to be discarded. - ((null (cadr destination)) - (setq stderr "/dev/null")))) - ;; 't - (destination - (setq outbuf (current-buffer)))) - (when stderr (setq command (format "%s 2>%s" command stderr))) - - ;; Send the command. It might not return in time, so we protect - ;; it. Call it in a subshell, in order to preserve working - ;; directory. - (condition-case nil - (unwind-protect - (setq ret - (tramp-send-command-and-check - v (format "\\cd %s; %s" - (tramp-shell-quote-argument localname) - command) - t t)) - ;; We should show the output anyway. - (when outbuf - (with-current-buffer outbuf - (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) - (when display (display-buffer outbuf)))) - ;; When the user did interrupt, we should do it also. We use - ;; return code -1 as marker. - (quit - (kill-buffer (tramp-get-connection-buffer v)) - (setq ret -1)) - ;; Handle errors. - (error - (kill-buffer (tramp-get-connection-buffer v)) - (setq ret 1))) - - ;; Provide error file. - (when tmpstderr (rename-file tmpstderr (cadr destination) t)) - - ;; Cleanup. We remove all file cache values for the connection, - ;; because the remote process could have changed them. - (when tmpinput (delete-file tmpinput)) - - ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to `nil', no remote file will be changed - ;; by `program'. If it doesn't exist, we assume its default - ;; value 't'. - (unless (and (boundp 'process-file-side-effects) - (not (symbol-value 'process-file-side-effects))) - (tramp-flush-directory-property v "")) - - ;; Return exit status. - (if (equal ret -1) - (keyboard-quit) - ret)))) - -(defun tramp-local-call-process - (program &optional infile destination display &rest args) - "Calls `call-process' on the local host. -This is needed because for some Emacs flavors Tramp has -defadviced `call-process' to behave like `process-file'. The -Lisp error raised when PROGRAM is nil is trapped also, returning 1." - (let ((default-directory - (if (file-remote-p default-directory) - (tramp-compat-temporary-file-directory) - default-directory))) - (if (executable-find program) - (apply 'call-process program infile destination display args) - 1))) - -(defun tramp-handle-call-process-region - (start end program &optional delete buffer display &rest args) - "Like `call-process-region' for Tramp files." - (let ((tmpfile (tramp-compat-make-temp-file ""))) - (write-region start end tmpfile) - (when delete (delete-region start end)) - (unwind-protect - (apply 'call-process program tmpfile buffer display args) - (delete-file tmpfile)))) - -(defun tramp-handle-shell-command - (command &optional output-buffer error-buffer) - "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (list - (tramp-get-method-parameter - (tramp-file-name-method - (tramp-dissect-file-name default-directory)) - 'tramp-remote-sh) - "-c" (substring command 0 asynchronous))) - current-buffer-p - (output-buffer - (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) - (output-buffer - (setq current-buffer-p t) - (current-buffer)) - (t (get-buffer-create - (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) - (error-buffer - (cond - ((bufferp error-buffer) error-buffer) - ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. - (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (condition-case nil - (kill-process p) - (error nil)) - (error "Shell command in progress"))) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) - (with-current-buffer output-buffer - (setq buffer-read-only nil) - (erase-buffer))) - - (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (apply 'start-file-process "*Async Shell*" buffer args) - ;; Display output. - (pop-to-buffer output-buffer) - (setq mode-line-process '(":%s")) - (require 'shell) (shell-mode)) - - (prog1 - ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) - ;; Insert error messages if they were separated. - (when (listp buffer) - (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) - (if current-buffer-p - ;; This is like exchange-point-and-mark, but doesn't - ;; activate the mark. It is cleaner to avoid activation, - ;; even though the command loop would deactivate the mark - ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) - ;; There's some output, display it. - (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (if (functionp 'display-message-or-buffer) - (tramp-compat-funcall 'display-message-or-buffer output-buffer) - (pop-to-buffer output-buffer)))))))) - -;; File Editing. - (defvar tramp-handle-file-local-copy-hook nil "Normal hook to be run at the end of `tramp-handle-file-local-copy'.") -(defun tramp-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - - (let* ((size (nth 7 (file-attributes filename))) - (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) - (loc-dec (tramp-get-inline-coding v "local-decoding" size)) - (tmpfile (tramp-compat-make-temp-file filename))) - - (condition-case err - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (copy-file filename tmpfile t t)) - - ;; Use inline encoding for file transfer. - (rem-enc - (save-excursion - (with-progress-reporter - v 3 (format "Encoding remote file %s" filename) - (tramp-barf-unless-okay - v (format rem-enc (tramp-shell-quote-argument localname)) - "Encoding remote file failed")) - - (if (functionp loc-dec) - ;; If local decoding is a function, we call it. We - ;; must disable multibyte, because - ;; `uudecode-decode-region' doesn't handle it - ;; correctly. - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (with-progress-reporter - v 3 (format "Decoding remote file %s with function %s" - filename loc-dec) - (funcall loc-dec (point-min) (point-max)) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfile)))) - - ;; If tramp-decoding-function is not defined for this - ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfile2 (tramp-compat-make-temp-file filename))) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfile2)) - (with-progress-reporter - v 3 (format "Decoding remote file %s with command %s" - filename loc-dec) - (unwind-protect - (tramp-call-local-coding-command - loc-dec tmpfile2 tmpfile) - (delete-file tmpfile2))))) - - ;; Set proper permissions. - (set-file-modes tmpfile (tramp-default-file-modes filename)) - ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfile))) - - ;; Oops, I don't know what to do. - (t (tramp-error - v 'file-error "Wrong method specification for `%s'" method))) - - ;; Error handling. - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - (run-hooks 'tramp-handle-file-local-copy-hook) - tmpfile))) - -(defun tramp-handle-file-remote-p (filename &optional identification connected) - "Like `file-remote-p' for Tramp files." - (let ((tramp-verbose 3)) - (when (tramp-tramp-file-p filename) - (let* ((v (tramp-dissect-file-name filename)) - (p (tramp-get-connection-process v)) - (c (and p (processp p) (memq (process-status p) '(run open))))) - ;; We expand the file name only, if there is already a connection. - (with-parsed-tramp-file-name - (if c (expand-file-name filename) filename) nil - (and (or (not connected) c) - (cond - ((eq identification 'method) method) - ((eq identification 'user) user) - ((eq identification 'host) host) - ((eq identification 'localname) localname) - (t (tramp-make-tramp-file-name method user host ""))))))))) - (defun tramp-find-file-name-coding-system-alist (filename tmpname) "Like `find-operation-coding-system' for Tramp filenames. Tramp's `insert-file-contents' and `write-region' work over @@ -4915,532 +1676,6 @@ (add-to-list 'result (cons (regexp-quote tmpname) (cdr elt)) 'append))))) -(defun tramp-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (setq filename (expand-file-name filename)) - (let (result local-copy remote-copy) - (with-parsed-tramp-file-name filename nil - (unwind-protect - (if (not (file-exists-p filename)) - ;; We don't raise a Tramp error, because it might be - ;; suppressed, like in `find-file-noselect-1'. - (signal 'file-error - (list "File not found on remote host" filename)) - - (if (and (tramp-local-host-p v) - (let (file-name-handler-alist) - (file-readable-p localname))) - ;; Short track: if we are on the local host, we can - ;; run directly. - (setq result - (tramp-run-real-handler - 'insert-file-contents - (list localname visit beg end replace))) - - ;; When we shall insert only a part of the file, we copy - ;; this part. - (when (or beg end) - (setq remote-copy (tramp-make-tramp-temp-file v)) - (tramp-send-command - v - (cond - ((and beg end) - (format "tail -c +%d %s | head -c +%d >%s" - (1+ beg) (tramp-shell-quote-argument localname) - (- end beg) remote-copy)) - (beg - (format "tail -c +%d %s >%s" - (1+ beg) (tramp-shell-quote-argument localname) - remote-copy)) - (end - (format "head -c +%d %s >%s" - (1+ end) (tramp-shell-quote-argument localname) - remote-copy))))) - - ;; `insert-file-contents-literally' takes care to avoid - ;; calling jka-compr. By let-binding - ;; `inhibit-file-name-operation', we propagate that care - ;; to the `file-local-copy' operation. - (setq local-copy - (let ((inhibit-file-name-operation - (when (eq inhibit-file-name-operation - 'insert-file-contents) - 'file-local-copy))) - (cond - ((stringp remote-copy) - (file-local-copy - (tramp-make-tramp-file-name - method user host remote-copy))) - ((stringp tramp-temp-buffer-file-name) - (copy-file filename tramp-temp-buffer-file-name 'ok) - tramp-temp-buffer-file-name) - (t (file-local-copy filename))))) - - ;; When the file is not readable for the owner, it - ;; cannot be inserted, even it is redable for the group - ;; or for everybody. - (set-file-modes local-copy (tramp-octal-to-decimal "0600")) - - (when (and (null remote-copy) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - ;; We keep the local file for performance reasons, - ;; useful for "rsync". - (setq tramp-temp-buffer-file-name local-copy) - (put 'tramp-temp-buffer-file-name 'permanent-local t)) - - (with-progress-reporter - v 3 (format "Inserting local temp file `%s'" local-copy) - ;; We must ensure that `file-coding-system-alist' - ;; matches `local-copy'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist - filename local-copy))) - (setq result - (insert-file-contents - local-copy nil nil nil replace)))))) - - ;; Save exit. - (progn - (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (when (and (stringp local-copy) - (or remote-copy (null tramp-temp-buffer-file-name))) - (delete-file local-copy)) - (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name method user host remote-copy)))))) - - ;; Result. - (list (expand-file-name filename) - (cadr result)))) - -;; This is needed for XEmacs only. Code stolen from files.el. -(defun tramp-handle-insert-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally' for Tramp files." - (let ((format-alist nil) - (after-insert-file-functions nil) - (coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil)) - (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) - (inhibit-file-name-operation 'insert-file-contents)) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (filename) t)) - (insert-file-contents filename visit beg end replace)) - ;; Save exit. - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) - -(defun tramp-handle-find-backup-file-name (filename) - "Like `find-backup-file-name' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; We set both variables. It doesn't matter whether it is - ;; Emacs or XEmacs. - (let ((backup-directory-alist - ;; Emacs case. - (when (boundp 'backup-directory-alist) - (if (symbol-value 'tramp-backup-directory-alist) - (mapcar - (lambda (x) - (cons - (car x) - (if (and (stringp (cdr x)) - (file-name-absolute-p (cdr x)) - (not (tramp-file-name-p (cdr x)))) - (tramp-make-tramp-file-name method user host (cdr x)) - (cdr x)))) - (symbol-value 'tramp-backup-directory-alist)) - (symbol-value 'backup-directory-alist)))) - - (bkup-backup-directory-info - ;; XEmacs case. - (when (boundp 'bkup-backup-directory-info) - (if (symbol-value 'tramp-bkup-backup-directory-info) - (mapcar - (lambda (x) - (nconc - (list (car x)) - (list - (if (and (stringp (car (cdr x))) - (file-name-absolute-p (car (cdr x))) - (not (tramp-file-name-p (car (cdr x))))) - (tramp-make-tramp-file-name - method user host (car (cdr x))) - (car (cdr x)))) - (cdr (cdr x)))) - (symbol-value 'tramp-bkup-backup-directory-info)) - (symbol-value 'bkup-backup-directory-info))))) - - (tramp-run-real-handler 'find-backup-file-name (list filename))))) - -(defun tramp-handle-make-auto-save-file-name () - "Like `make-auto-save-file-name' for Tramp files. -Returns a file name in `tramp-auto-save-directory' for autosaving this file." - (let ((tramp-auto-save-directory tramp-auto-save-directory) - (buffer-file-name - (tramp-subst-strs-in-string - '(("_" . "|") - ("/" . "_a") - (":" . "_b") - ("|" . "__") - ("[" . "_l") - ("]" . "_r")) - (buffer-file-name)))) - ;; File name must be unique. This is ensured with Emacs 22 (see - ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for - ;; all other cases we must do it ourselves. - (when (boundp 'auto-save-file-name-transforms) - (mapc - (lambda (x) - (when (and (string-match (car x) buffer-file-name) - (not (car (cddr x)))) - (setq tramp-auto-save-directory - (or tramp-auto-save-directory - (tramp-compat-temporary-file-directory))))) - (symbol-value 'auto-save-file-name-transforms))) - ;; Create directory. - (when tramp-auto-save-directory - (setq buffer-file-name - (expand-file-name buffer-file-name tramp-auto-save-directory)) - (unless (file-exists-p tramp-auto-save-directory) - (make-directory tramp-auto-save-directory t))) - ;; Run plain `make-auto-save-file-name'. There might be an advice when - ;; it is not a magic file name operation (since Emacs 22). - ;; We must deactivate it temporarily. - (if (not (ad-is-active 'make-auto-save-file-name)) - (tramp-run-real-handler 'make-auto-save-file-name nil) - ;; else - (ad-deactivate 'make-auto-save-file-name) - (prog1 - (tramp-run-real-handler 'make-auto-save-file-name nil) - (ad-activate 'make-auto-save-file-name))))) - -(defvar tramp-handle-write-region-hook nil - "Normal hook to be run at the end of `tramp-handle-write-region'.") - -;; CCC grok LOCKNAME -(defun tramp-handle-write-region - (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; Following part commented out because we don't know what to do about - ;; file locking, and it does not appear to be a problem to ignore it. - ;; Ange-ftp ignores it, too. - ;; (when (and lockname (stringp lockname)) - ;; (setq lockname (expand-file-name lockname))) - ;; (unless (or (eq lockname nil) - ;; (string= lockname filename)) - ;; (error - ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME")) - - ;; XEmacs takes a coding system as the seventh argument, not `confirm'. - (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) - (tramp-error v 'file-error "File not overwritten"))) - - (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) - (tramp-get-remote-uid v 'integer))) - (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (let (file-name-handler-alist) - (and - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))))) - ;; Short track: if we are on the local host, we can run directly. - (tramp-run-real-handler - 'write-region - (list start end localname append 'no-message lockname confirm)) - - (let ((modes (save-excursion (tramp-default-file-modes filename))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp - ;; file. At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic - ;; simpler. - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) - - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) - - ;; We say `no-message' here because we don't want the - ;; visited file modtime data to be clobbered from the temp - ;; file. We call `set-visited-file-modtime' ourselves later - ;; on. We must ensure that `file-coding-system-alist' - ;; matches `tmpfile'. - (let (file-name-handler-alist - (file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile))) - (condition-case err - (tramp-run-real-handler - 'write-region - (list start end tmpfile append 'no-message lockname confirm)) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. Remember it. - (when (boundp 'last-coding-system-used) - (setq coding-system-used - (symbol-value 'last-coding-system-used)))) - - ;; The permissions of the temporary file should be set. If - ;; filename does not exist (eq modes nil) it has been - ;; renamed to the backup file. This case `save-buffer' - ;; handles permissions. - ;; Ensure, that it is still readable. - (when modes - (set-file-modes - tmpfile (logior (or modes 0) (tramp-octal-to-decimal "0400")))) - - ;; This is a bit lengthy due to the different methods - ;; possible for file transfer. First, we check whether the - ;; method uses an rcp program. If so, we call it. - ;; Otherwise, both encoding and decoding command must be - ;; specified. However, if the method _also_ specifies an - ;; encoding function, then that is used for encoding the - ;; contents of the tmp file. - (let* ((size (nth 7 (file-attributes tmpfile))) - (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) - (loc-enc (tramp-get-inline-coding v "local-encoding" size))) - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. - (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. - (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (if (functionp loc-enc) - (with-progress-reporter - v 3 (format "Encoding region using function `%s'" - loc-enc) - (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally tmpfile)) - ;; The following `let' is a workaround for the - ;; base64.el that comes with pgnus-0.84. If - ;; both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (funcall loc-enc (point-min) (point-max)))) - - (with-progress-reporter - v 3 (format "Encoding region using command `%s'" - loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-progress-reporter - v 3 - (format "Decoding region into remote file %s" filename) - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-send-command - v - (format - (concat rem-dec " <<'EOF'\n%sEOF") - (tramp-shell-quote-argument localname) - (buffer-string))) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-local-call-process "cksum" tmpfile t)) - ;; cksum runs remotely. - (zerop - (tramp-send-command-and-check - v - (format - "cksum <%s" - (tramp-shell-quote-argument localname)))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))))) - - ;; Save exit. - (delete-file tmpfile))) - - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an rcp program") - method)))) - - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (set 'last-coding-system-used coding-system-used)))) - - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - - ;; We must protect `last-coding-system-used', now we have set it - ;; to its correct value. - (let (last-coding-system-used (need-chown t)) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (let ((file-attr (file-attributes filename))) - (set-visited-file-modtime - ;; We must pass modtime explicitely, because filename can - ;; be different from (buffer-file-name), f.e. if - ;; `file-precious-flag' is set. - (nth 5 file-attr)) - (when (and (eq (nth 2 file-attr) uid) - (eq (nth 3 file-attr) gid)) - (setq need-chown nil)))) - - ;; Set the ownership. - (when need-chown - (tramp-set-file-uid-gid filename uid gid)) - (when (or (eq visit t) (null visit) (stringp visit)) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))))) - -(defvar tramp-vc-registered-file-names nil - "List used to collect file names, which are checked during `vc-registered'.") - -;; VC backends check for the existence of various different special -;; files. This is very time consuming, because every single check -;; requires a remote command (the file cache must be invalidated). -;; Therefore, we apply a kind of optimization. We install the file -;; name handler `tramp-vc-file-name-handler', which does nothing but -;; remembers all file names for which `file-exists-p' or -;; `file-readable-p' has been applied. A first run of `vc-registered' -;; is performed. Afterwards, a script is applied for all collected -;; file names, using just one remote command. The result of this -;; script is used to fill the file cache with actual values. Now we -;; can reset the file name handlers, and we make a second run of -;; `vc-registered', which returns the expected result without sending -;; any other remote command. -(defun tramp-handle-vc-registered (file) - "Like `vc-registered' for Tramp files." - (with-temp-message "" - (with-parsed-tramp-file-name file nil - (with-progress-reporter - v 3 (format "Checking `vc-registered' for %s" file) - - ;; There could be new files, created by the vc backend. We - ;; cannot reuse the old cache entries, therefore. - (let (tramp-vc-registered-file-names - (tramp-cache-inhibit-cache (current-time)) - (file-name-handler-alist - `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) - - ;; Here we collect only file names, which need an operation. - (tramp-run-real-handler 'vc-registered (list file)) - (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) - - ;; Send just one command, in order to fill the cache. - (when tramp-vc-registered-file-names - (tramp-maybe-send-script - v - (format tramp-vc-registered-read-file-names - (tramp-get-file-exists-command v) - (format "%s -r" (tramp-get-test-command v))) - "tramp_vc_registered_read_file_names") - - (dolist - (elt - (tramp-send-command-and-read - v - (format - "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" - (mapconcat 'tramp-shell-quote-argument - tramp-vc-registered-file-names - "\n")))) - - (tramp-set-file-property - v (car elt) (cadr elt) (cadr (cdr elt)))))) - - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' in order to keep the cache when - ;; `process-file' calls appear. - (let (process-file-side-effects) - (tramp-run-real-handler 'vc-registered (list file))))))) - ;;;###autoload (progn (defun tramp-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. @@ -5601,8 +1836,7 @@ (condition-case err (apply foreign operation args) - ;; Trace that somebody has interrupted the - ;; operation. + ;; Trace, that somebody has interrupted the operation. (quit (let (tramp-message-show-message) (tramp-message @@ -5660,48 +1894,6 @@ Together with `tramp-locked', this implements a locking mechanism preventing reentrant calls of Tramp.") -(defun tramp-sh-file-name-handler (operation &rest args) - "Invoke remote-shell Tramp file name handler. -Fall back to normal file name handler if no Tramp handler exists." - (when (and tramp-locked (not tramp-locker)) - (setq tramp-locked nil) - (signal 'file-error (list "Forbidden reentrant call of Tramp"))) - (let ((tl tramp-locked)) - (unwind-protect - (progn - (setq tramp-locked t) - (let ((tramp-locker t)) - (save-match-data - (let ((fn (assoc operation tramp-file-name-handler-alist))) - (if fn - (apply (cdr fn) args) - (tramp-run-real-handler operation args)))))) - (setq tramp-locked tl)))) - -(defun tramp-vc-file-name-handler (operation &rest args) - "Invoke special file name handler, which collects files to be handled." - (save-match-data - (let ((filename - (tramp-replace-environment-variables - (apply 'tramp-file-name-for-operation operation args))) - (fn (assoc operation tramp-file-name-handler-alist))) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume, that VC uses only `file-exists-p' and - ;; `file-readable-p' checks; otherwise we must extend the - ;; list. We do not perform any action, but return nil, in - ;; order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn - (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args))))))) - ;;;###autoload (progn (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler. @@ -5795,6 +1987,7 @@ ;; Tramp file name syntax. Maybe another variable should be introduced ;; overwriting this check in such cases. Or we change Tramp file name ;; syntax in order to avoid ambiguities, like in XEmacs ... +;;;###tramp-autoload (defun tramp-completion-mode-p () "Check, whether method / user name / host name completion is active." (or @@ -5899,12 +2092,11 @@ ;; Complete local parts. (append result1 - (condition-case nil - (apply (if (tramp-connectable-p fullname) - 'tramp-completion-run-real-handler - 'tramp-run-real-handler) - 'file-name-all-completions (list (list filename directory))) - (error nil))))) + (ignore-errors + (apply (if (tramp-connectable-p fullname) + 'tramp-completion-run-real-handler + 'tramp-run-real-handler) + 'file-name-all-completions (list (list filename directory))))))) ;; Method, host name and user name completion for a file. ;;;###autoload @@ -6344,7 +2536,7 @@ (let ((default-directory (tramp-compat-temporary-file-directory)) res) (with-temp-buffer - (when (zerop (tramp-local-call-process "reg" nil t nil "query" registry)) + (when (zerop (tramp-compat-call-process "reg" nil t nil "query" registry)) (goto-char (point-min)) (while (not (eobp)) (push (tramp-parse-putty-group registry) res)))) @@ -6362,81 +2554,10 @@ (forward-line 1) result)) -;;; Internal Functions: - -(defun tramp-maybe-send-script (vec script name) - "Define in remote shell function NAME implemented as SCRIPT. -Only send the definition if it has not already been done." - (let* ((p (tramp-get-connection-process vec)) - (scripts (tramp-get-connection-property p "scripts" nil))) - (unless (member name scripts) - (with-progress-reporter vec 5 (format "Sending script `%s'" name) - ;; The script could contain a call of Perl. This is masked with `%s'. - (tramp-send-command-and-check - vec - (format "%s () {\n%s\n}" name - (format script (tramp-get-remote-perl vec)))) - (tramp-set-connection-property p "scripts" (cons name scripts)))))) - -(defun tramp-set-auto-save () - (when (and ;; ange-ftp has its own auto-save mechanism - (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) - 'tramp-sh-file-name-handler) - auto-save-default) - (auto-save-mode 1))) -(add-hook 'find-file-hooks 'tramp-set-auto-save t) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'find-file-hooks 'tramp-set-auto-save))) - -(defun tramp-run-test (switch filename) - "Run `test' on the remote system, given a SWITCH and a FILENAME. -Returns the exit code of the `test' program." - (with-parsed-tramp-file-name filename nil - (tramp-send-command-and-check - v - (format - "%s %s %s" - (tramp-get-test-command v) - switch - (tramp-shell-quote-argument localname))))) - -(defun tramp-run-test2 (format-string file1 file2) - "Run `test'-like program on the remote system, given FILE1, FILE2. -FORMAT-STRING contains the program name, switches, and place holders. -Returns the exit code of the `test' program. Barfs if the methods, -hosts, or files, disagree." - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "tramp-run-test2 only implemented for same method, user, host"))) - (with-parsed-tramp-file-name file1 v1 - (with-parsed-tramp-file-name file1 v2 - (tramp-send-command-and-check - v1 - (format format-string - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)))))) - -(defun tramp-buffer-name (vec) - "A name for the connection buffer VEC." - ;; We must use `tramp-file-name-real-host', because for gateway - ;; methods the default port will be expanded later on, which would - ;; tamper the name. - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec))) - (if (not (zerop (length user))) - (format "*tramp/%s %s@%s*" method user host) - (format "*tramp/%s %s*" method host)))) - (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." (when (stringp tramp-temp-buffer-file-name) - (condition-case nil - (delete-file tramp-temp-buffer-file-name) - (error nil)))) + (ignore-errors (delete-file tramp-temp-buffer-file-name)))) (add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function) (add-hook 'tramp-cache-unload-hook @@ -6444,241 +2565,6 @@ (remove-hook 'kill-buffer-hook 'tramp-delete-temp-file-function))) -(defun tramp-get-buffer (vec) - "Get the connection buffer to be used for VEC." - (or (get-buffer (tramp-buffer-name vec)) - (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - "/")) - (current-buffer)))) - -(defun tramp-get-connection-buffer (vec) - "Get the connection buffer to be used for VEC. -In case a second asynchronous communication has been started, it is different -from `tramp-get-buffer'." - (or (tramp-get-connection-property vec "process-buffer" nil) - (tramp-get-buffer vec))) - -(defun tramp-get-connection-process (vec) - "Get the connection process to be used for VEC. -In case a second asynchronous communication has been started, it is different -from the default one." - (get-process - (or (tramp-get-connection-property vec "process-name" nil) - (tramp-buffer-name vec)))) - -(defun tramp-debug-buffer-name (vec) - "A name for the debug buffer for VEC." - ;; We must use `tramp-file-name-real-host', because for gateway - ;; methods the default port will be expanded later on, which would - ;; tamper the name. - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec))) - (if (not (zerop (length user))) - (format "*debug tramp/%s %s@%s*" method user host) - (format "*debug tramp/%s %s*" method host)))) - -(defconst tramp-debug-outline-regexp - "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #") - -(defun tramp-get-debug-buffer (vec) - "Get the debug buffer for VEC." - (with-current-buffer - (get-buffer-create (tramp-debug-buffer-name vec)) - (when (bobp) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; Furthermore, `outline-regexp' must have the correct value - ;; already, because it is used by `font-lock-compile-keywords'. - (let ((default-directory (tramp-compat-temporary-file-directory)) - (outline-regexp tramp-debug-outline-regexp)) - (outline-mode)) - (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) - (set (make-local-variable 'outline-level) 'tramp-outline-level)) - (current-buffer))) - -(defun tramp-outline-level () - "Return the depth to which a statement is nested in the outline. -Point must be at the beginning of a header line. - -The outline level is equal to the verbosity of the Tramp message." - (1+ (string-to-number (match-string 1)))) - -(defun tramp-find-executable - (vec progname dirlist &optional ignore-tilde ignore-path) - "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST. -First arg VEC specifies the connection, PROGNAME is the program -to search for, and DIRLIST gives the list of directories to -search. If IGNORE-TILDE is non-nil, directory names starting -with `~' will be ignored. If IGNORE-PATH is non-nil, searches -only in DIRLIST. - -Returns the absolute file name of PROGNAME, if found, and nil otherwise. - -This function expects to be in the right *tramp* buffer." - (with-current-buffer (tramp-get-connection-buffer vec) - (let (result) - ;; Check whether the executable is in $PATH. "which(1)" does not - ;; report always a correct error code; therefore we check the - ;; number of words it returns. - (unless ignore-path - (tramp-send-command vec (format "which \\%s | wc -w" progname)) - (goto-char (point-min)) - (if (looking-at "^\\s-*1$") - (setq result (concat "\\" progname)))) - (unless result - (when ignore-tilde - ;; Remove all ~/foo directories from dirlist. In XEmacs, - ;; `remove' is in CL, and we want to avoid CL dependencies. - (let (newdl d) - (while dirlist - (setq d (car dirlist)) - (setq dirlist (cdr dirlist)) - (unless (char-equal ?~ (aref d 0)) - (setq newdl (cons d newdl)))) - (setq dirlist (nreverse newdl)))) - (tramp-send-command - vec - (format (concat "while read d; " - "do if test -x $d/%s -a -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'EOF'\n" - "%s\nEOF") - progname progname progname (mapconcat 'identity dirlist "\n"))) - (goto-char (point-max)) - (when (search-backward "tramp_executable " nil t) - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq result (buffer-substring - (point) (tramp-compat-line-end-position))))) - result))) - -(defun tramp-set-remote-path (vec) - "Sets the remote environment PATH to existing directories. -I.e., for each directory in `tramp-remote-path', it is tested -whether it exists and if so, it is added to the environment -variable PATH." - (tramp-message vec 5 (format "Setting $PATH environment variable")) - (tramp-send-command - vec (format "PATH=%s; export PATH" - (mapconcat 'identity (tramp-get-remote-path vec) ":")))) - -;; ------------------------------------------------------------ -;; -- Communication with external shell -- -;; ------------------------------------------------------------ - -(defun tramp-find-file-exists-command (vec) - "Find a command on the remote host for checking if a file exists. -Here, we are looking for a command which has zero exit status if the -file exists and nonzero exit status otherwise." - (let ((existing "/") - (nonexisting - (tramp-shell-quote-argument "/ this file does not exist ")) - result) - ;; The algorithm is as follows: we try a list of several commands. - ;; For each command, we first run `$cmd /' -- this should return - ;; true, as the root directory always exists. And then we run - ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed - ;; does not exist. This should return false. We use the first - ;; command we find that seems to work. - ;; The list of commands to try is as follows: - ;; `ls -d' This works on most systems, but NetBSD 1.4 - ;; has a bug: `ls' always returns zero exit - ;; status, even for files which don't exist. - ;; `test -e' Some Bourne shells have a `test' builtin - ;; which does not know the `-e' option. - ;; `/bin/test -e' For those, the `test' binary on disk normally - ;; provides the option. Alas, the binary - ;; is sometimes `/bin/test' and sometimes it's - ;; `/usr/bin/test'. - ;; `/usr/bin/test -e' In case `/bin/test' does not exist. - (unless (or - (and (setq result (format "%s -e" (tramp-get-test-command vec))) - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result "/bin/test -e") - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result "/usr/bin/test -e") - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result (format "%s -d" (tramp-get-ls-command vec))) - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting)))))) - (tramp-error - vec 'file-error "Couldn't find command to check if file exists")) - result)) - -(defun tramp-open-shell (vec shell) - "Opens shell SHELL." - (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell) - ;; Find arguments for this shell. - (let ((tramp-end-of-output tramp-initial-end-of-output) - (alist tramp-sh-extra-args) - item extra-args) - (while (and alist (null extra-args)) - (setq item (pop alist)) - (when (string-match (car item) shell) - (setq extra-args (cdr item)))) - (when extra-args (setq shell (concat shell " " extra-args))) - (tramp-send-command - vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s" - (shell-quote-argument tramp-end-of-output) shell) - t)) - ;; Setting prompts. - (tramp-send-command - vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t))) - -(defun tramp-find-shell (vec) - "Opens a shell on the remote host which groks tilde expansion." - (unless (tramp-get-connection-property vec "remote-shell" nil) - (let (shell) - (with-current-buffer (tramp-get-buffer vec) - (tramp-send-command vec "echo ~root" t) - (cond - ((or (string-match "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris is buggy. - (string-equal (tramp-get-connection-property vec "uname" "") - "SunOS 5.11")) - (setq shell - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t))) - (unless shell - (tramp-error - vec 'file-error - "Couldn't find a shell which groks tilde expansion")) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" shell) - (tramp-open-shell vec shell)) - - (t (tramp-message - vec 5 "Remote `%s' groks tilde expansion, good" - (tramp-set-connection-property - vec "remote-shell" - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-sh))))))))) - ;; ------------------------------------------------------------ ;; -- Functions for establishing connection -- ;; ------------------------------------------------------------ @@ -6804,7 +2690,7 @@ (defun tramp-process-actions (proc vec actions &optional timeout) "Perform actions until success or TIMEOUT." ;; Preserve message for `progress-reporter'. - (with-temp-message "" + (tramp-compat-with-temp-message "" ;; Enable auth-source and password-cache. (tramp-set-connection-property vec "first-password-request" t) (let (exit) @@ -6912,17 +2798,6 @@ (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) found))) -(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args) - "Wait for shell prompt and barf if none appears. -Looks at process PROC to see if a shell prompt appears in TIMEOUT -seconds. If not, it produces an error message with the given ERROR-ARGS." - (unless - (tramp-wait-for-regexp - proc timeout - (format - "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) - (apply 'tramp-error-with-buffer nil proc 'file-error error-args))) - ;; We don't call `tramp-send-string' in order to hide the password ;; from the debug buffer, and because end-of-line handling of the ;; string. @@ -6935,820 +2810,6 @@ 'tramp-password-end-of-line) tramp-default-password-end-of-line)))) -(defun tramp-open-connection-setup-interactive-shell (proc vec) - "Set up an interactive shell. -Mainly sets the prompt and the echo correctly. PROC is the shell -process to set up. VEC specifies the connection." - (let ((tramp-end-of-output tramp-initial-end-of-output)) - ;; It is useful to set the prompt in the following command because - ;; some people have a setting for $PS1 which /bin/sh doesn't know - ;; about and thus /bin/sh will display a strange prompt. For - ;; example, if $PS1 has "${CWD}" in the value, then ksh will - ;; display the current working directory but /bin/sh will display - ;; a dollar sign. The following command line sets $PS1 to a sane - ;; value, and works under Bourne-ish shells as well as csh-like - ;; shells. Daniel Pittman reports that the unusual positioning of - ;; the single quotes makes it work under `rc', too. We also unset - ;; the variable $ENV because that is read by some sh - ;; implementations (eg, bash when called as sh) on startup; this - ;; way, we avoid the startup file clobbering $PS1. $PROMP_COMMAND - ;; is another way to set the prompt in /bin/bash, it must be - ;; discarded as well. - (tramp-open-shell - vec - (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh)) - - ;; Disable echo. - (tramp-message vec 5 "Setting up remote shell environment") - (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) - ;; Check whether the echo has really been disabled. Some - ;; implementations, like busybox of embedded GNU/Linux, don't - ;; support disabling. - (tramp-send-command vec "echo foo" t) - (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (when (looking-at "echo foo") - (tramp-set-connection-property proc "remote-echo" t) - (tramp-message vec 5 "Remote echo still on. Ok.") - ;; Make sure backspaces and their echo are enabled and no line - ;; width magic interferes with them. - (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) - - (tramp-message vec 5 "Setting shell prompt") - (tramp-send-command - vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t) - - ;; Try to set up the coding system correctly. - ;; CCC this can't be the right way to do it. Hm. - (tramp-message vec 5 "Determining coding system") - (tramp-send-command vec "echo foo ; echo bar" t) - (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (if (featurep 'mule) - ;; Use MULE to select the right EOL convention for communicating - ;; with the process. - (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc) - (cons 'undecided 'undecided))) - cs-decode cs-encode) - (when (symbolp cs) (setq cs (cons cs cs))) - (setq cs-decode (car cs)) - (setq cs-encode (cdr cs)) - (unless cs-decode (setq cs-decode 'undecided)) - (unless cs-encode (setq cs-encode 'undecided)) - (setq cs-encode (tramp-coding-system-change-eol-conversion - cs-encode 'unix)) - (when (search-forward "\r" nil t) - (setq cs-decode (tramp-coding-system-change-eol-conversion - cs-decode 'dos))) - (tramp-compat-funcall - 'set-buffer-process-coding-system cs-decode cs-encode) - (tramp-message - vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode)) - ;; Look for ^M and do something useful if found. - (when (search-forward "\r" nil t) - ;; We have found a ^M but cannot frob the process coding system - ;; because we're running on a non-MULE Emacs. Let's try - ;; stty, instead. - (tramp-send-command vec "stty -onlcr" t)))) - ;; Dump stty settings in the traces. - (when (>= tramp-verbose 9) - (tramp-send-command vec "stty -a" t)) - (tramp-send-command vec "set +o vi +o emacs" t) - - ;; Check whether the output of "uname -sr" has been changed. If - ;; yes, this is a strong indication that we must expire all - ;; connection properties. We start again with - ;; `tramp-maybe-open-connection', it will be catched there. - (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (new-uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) - (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) - (with-current-buffer (tramp-get-debug-buffer vec) - ;; Keep the debug buffer. - (rename-buffer - (generate-new-buffer-name tramp-temp-buffer-name) 'unique) - (tramp-compat-funcall 'tramp-cleanup-connection vec) - (if (= (point-min) (point-max)) - (kill-buffer nil) - (rename-buffer (tramp-debug-buffer-name vec) 'unique)) - ;; We call `tramp-get-buffer' in order to keep the debug buffer. - (tramp-get-buffer vec) - (tramp-message - vec 3 - "Connection reset, because remote host changed from `%s' to `%s'" - old-uname new-uname) - (throw 'uname-changed (tramp-maybe-open-connection vec))))) - - ;; Check whether the remote host suffers from buggy - ;; `send-process-string'. This is known for FreeBSD (see comment in - ;; `send_process', file process.c). I've tested sending 624 bytes - ;; successfully, sending 625 bytes failed. Emacs makes a hack when - ;; this host type is detected locally. It cannot handle remote - ;; hosts, though. - (with-connection-property proc "chunksize" - (cond - ((and (integerp tramp-chunksize) (> tramp-chunksize 0)) - tramp-chunksize) - (t - (tramp-message - vec 5 "Checking remote host type for `send-process-string' bug") - (if (string-match - "^FreeBSD" (tramp-get-connection-property vec "uname" "")) - 500 0)))) - - ;; Set remote PATH variable. - (tramp-set-remote-path vec) - - ;; Search for a good shell before searching for a command which - ;; checks if a file exists. This is done because Tramp wants to use - ;; "test foo; echo $?" to check if various conditions hold, and - ;; there are buggy /bin/sh implementations which don't execute the - ;; "echo $?" part if the "test" part has an error. In particular, - ;; the OpenSolaris /bin/sh is a problem. There are also other - ;; problems with /bin/sh of OpenSolaris, like redirection of stderr - ;; in function declarations, or changing HISTFILE in place. - ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when - ;; detected. - (tramp-find-shell vec) - - ;; Disable unexpected output. - (tramp-send-command vec "mesg n; biff n" t) - - ;; IRIX64 bash expands "!" even when in single quotes. This - ;; destroys our shell functions, we must disable it. See - ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" "")) - (tramp-send-command vec "set +H" t)) - - ;; Set `remote-tty' process property. - (ignore-errors - (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\""))) - (unless (zerop (length tty)) (process-put proc 'remote-tty tty)))) - - ;; Set the environment. - (tramp-message vec 5 "Setting default environment") - - (let ((env (copy-sequence tramp-remote-process-environment)) - unset item) - (while env - (setq item (tramp-compat-split-string (car env) "=")) - (setcdr item (mapconcat 'identity (cdr item) "=")) - (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) - (tramp-send-command - vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t) - (push (car item) unset)) - (setq env (cdr env))) - (when unset - (tramp-send-command - vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) - -;; CCC: We should either implement a Perl version of base64 encoding -;; and decoding. Then we just use that in the last item. The other -;; alternative is to use the Perl version of UU encoding. But then -;; we need a Lisp version of uuencode. -;; -;; Old text from documentation of tramp-methods: -;; Using a uuencode/uudecode inline method is discouraged, please use one -;; of the base64 methods instead since base64 encoding is much more -;; reliable and the commands are more standardized between the different -;; Unix versions. But if you can't use base64 for some reason, please -;; note that the default uudecode command does not work well for some -;; Unices, in particular AIX and Irix. For AIX, you might want to use -;; the following command for uudecode: -;; -;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1 -;; -;; For Irix, no solution is known yet. - -(defconst tramp-local-coding-commands - '((b64 base64-encode-region base64-decode-region) - (uu tramp-uuencode-region uudecode-decode-region) - (pack - "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" - "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) - "List of local coding commands for inline transfer. -Each item is a list that looks like this: - -\(FORMAT ENCODING DECODING\) - -FORMAT is symbol describing the encoding/decoding format. It can be -`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. - -ENCODING and DECODING can be strings, giving commands, or symbols, -giving functions. If they are strings, then they can contain -the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the -specifier is not present, the input should be read from standard -input. - -If they are functions, they will be called with two arguments, start -and end of region, and are expected to replace the region contents -with the encoded or decoded results, respectively.") - -(defconst tramp-remote-coding-commands - '((b64 "base64" "base64 -d") - (b64 "mimencode -b" "mimencode -u -b") - (b64 "mmencode -b" "mmencode -u -b") - (b64 "recode data..base64" "recode base64..data") - (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) - (b64 tramp-perl-encode tramp-perl-decode) - (uu "uuencode xxx" "uudecode -o /dev/stdout") - (uu "uuencode xxx" "uudecode -o -") - (uu "uuencode xxx" "uudecode -p") - (uu "uuencode xxx" tramp-uudecode) - (pack - "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" - "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) - "List of remote coding commands for inline transfer. -Each item is a list that looks like this: - -\(FORMAT ENCODING DECODING\) - -FORMAT is symbol describing the encoding/decoding format. It can be -`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. - -ENCODING and DECODING can be strings, giving commands, or symbols, -giving variables. If they are strings, then they can contain -the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the -specifier is not present, the input should be read from standard -input. - -If they are variables, this variable is a string containing a Perl -implementation for this functionality. This Perl program will be transferred -to the remote host, and it is available as shell function with the same name.") - -(defun tramp-find-inline-encoding (vec) - "Find an inline transfer encoding that works. -Goes through the list `tramp-local-coding-commands' and -`tramp-remote-coding-commands'." - (save-excursion - (let ((local-commands tramp-local-coding-commands) - (magic "xyzzy") - loc-enc loc-dec rem-enc rem-dec litem ritem found) - (while (and local-commands (not found)) - (setq litem (pop local-commands)) - (catch 'wont-work-local - (let ((format (nth 0 litem)) - (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) - ;; If the local encoder or decoder is a string, the - ;; corresponding command has to work locally. - (if (not (stringp loc-enc)) - (tramp-message - vec 5 "Checking local encoding function `%s'" loc-enc) - (tramp-message - vec 5 "Checking local encoding command `%s' for sanity" loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc nil nil)) - (throw 'wont-work-local nil))) - (if (not (stringp loc-dec)) - (tramp-message - vec 5 "Checking local decoding function `%s'" loc-dec) - (tramp-message - vec 5 "Checking local decoding command `%s' for sanity" loc-dec) - (unless (zerop (tramp-call-local-coding-command - loc-dec nil nil)) - (throw 'wont-work-local nil))) - ;; Search for remote coding commands with the same format - (while (and remote-commands (not found)) - (setq ritem (pop remote-commands)) - (catch 'wont-work-remote - (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - ;; Check if remote encoding and decoding commands can be - ;; called remotely with null input and output. This makes - ;; sure there are no syntax errors and the command is really - ;; found. Note that we do not redirect stdout to /dev/null, - ;; for two reasons: when checking the decoding command, we - ;; actually check the output it gives. And also, when - ;; redirecting "mimencode" output to /dev/null, then as root - ;; it might change the permissions of /dev/null! - (when (not (stringp rem-enc)) - (let ((name (symbol-name rem-enc))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) - (setq rem-enc name))) - (tramp-message - vec 5 - "Checking remote encoding command `%s' for sanity" rem-enc) - (unless (zerop (tramp-send-command-and-check - vec (format "%s </dev/null" rem-enc) t)) - (throw 'wont-work-remote nil)) - - (when (not (stringp rem-dec)) - (let ((name (symbol-name rem-dec))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-dec) name) - (setq rem-dec name))) - (tramp-message - vec 5 - "Checking remote decoding command `%s' for sanity" rem-dec) - (unless (zerop (tramp-send-command-and-check - vec - (format "echo %s | %s | %s" - magic rem-enc rem-dec) - t)) - (throw 'wont-work-remote nil)) - - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (unless (looking-at (regexp-quote magic)) - (throw 'wont-work-remote nil))) - - ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) - - ;; Did we find something? - (unless found - (tramp-error - vec 'file-error "Couldn't find an inline transfer encoding")) - - ;; Set connection properties. - (tramp-message vec 5 "Using local encoding `%s'" loc-enc) - (tramp-set-connection-property vec "local-encoding" loc-enc) - (tramp-message vec 5 "Using local decoding `%s'" loc-dec) - (tramp-set-connection-property vec "local-decoding" loc-dec) - (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) - (tramp-set-connection-property vec "remote-encoding" rem-enc) - (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) - (tramp-set-connection-property vec "remote-decoding" rem-dec)))) - -(defun tramp-call-local-coding-command (cmd input output) - "Call the local encoding or decoding command. -If CMD contains \"%s\", provide input file INPUT there in command. -Otherwise, INPUT is passed via standard input. -INPUT can also be nil which means `/dev/null'. -OUTPUT can be a string (which specifies a filename), or t (which -means standard output and thus the current buffer), or nil (which -means discard it)." - (tramp-local-call-process - tramp-encoding-shell - (when (and input (not (string-match "%s" cmd))) input) - (if (eq output t) t nil) - nil - tramp-encoding-command-switch - (concat - (if (string-match "%s" cmd) (format cmd input) cmd) - (if (stringp output) (concat "> " output) "")))) - -(defconst tramp-inline-compress-commands - '(("gzip" "gzip -d") - ("bzip2" "bzip2 -d") - ("compress" "compress -d")) - "List of compress and decompress commands for inline transfer. -Each item is a list that looks like this: - -\(COMPRESS DECOMPRESS\) - -COMPRESS or DECOMPRESS are strings with the respective commands.") - -(defun tramp-find-inline-compress (vec) - "Find an inline transfer compress command that works. -Goes through the list `tramp-inline-compress-commands'." - (save-excursion - (let ((commands tramp-inline-compress-commands) - (magic "xyzzy") - item compress decompress - found) - (while (and commands (not found)) - (catch 'next - (setq item (pop commands) - compress (nth 0 item) - decompress (nth 1 item)) - (tramp-message - vec 5 - "Checking local compress command `%s', `%s' for sanity" - compress decompress) - (unless (zerop (tramp-call-local-coding-command - (format "echo %s | %s | %s" - magic compress decompress) nil nil)) - (throw 'next nil)) - (tramp-message - vec 5 - "Checking remote compress command `%s', `%s' for sanity" - compress decompress) - (unless (zerop (tramp-send-command-and-check - vec (format "echo %s | %s | %s" - magic compress decompress) t)) - (throw 'next nil)) - (setq found t))) - - ;; Did we find something? - (if found - (progn - ;; Set connection properties. - (tramp-message - vec 5 "Using inline transfer compress command `%s'" compress) - (tramp-set-connection-property vec "inline-compress" compress) - (tramp-message - vec 5 "Using inline transfer decompress command `%s'" decompress) - (tramp-set-connection-property vec "inline-decompress" decompress)) - - (tramp-set-connection-property vec "inline-compress" nil) - (tramp-set-connection-property vec "inline-decompress" nil) - (tramp-message - vec 2 "Couldn't find an inline transfer compress command"))))) - -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'. -Gateway hops are already opened." - (let ((target-alist `(,vec)) - (choices tramp-default-proxies-alist) - item proxy) - - ;; Look for proxy hosts to be passed. - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item))) - (when (and - ;; host - (string-match (or (eval (nth 0 item)) "") - (or (tramp-file-name-host (car target-alist)) "")) - ;; user - (string-match (or (eval (nth 1 item)) "") - (or (tramp-file-name-user (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. - (setq proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (add-to-list 'target-alist l) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Handle gateways. - (when (and (boundp 'tramp-gw-tunnel-method) - (string-match (format - "^\\(%s\\|%s\\)$" - (symbol-value 'tramp-gw-tunnel-method) - (symbol-value 'tramp-gw-socks-method)) - (tramp-file-name-method (car target-alist)))) - (let ((gw (pop target-alist)) - (hop (pop target-alist))) - ;; Is the method prepared for gateways? - (unless (tramp-get-method-parameter - (tramp-file-name-method hop) 'tramp-default-port) - (tramp-error - vec 'file-error - "Method `%s' is not supported for gateway access." - (tramp-file-name-method hop))) - ;; Add default port if needed. - (unless - (string-match - tramp-host-with-port-regexp (tramp-file-name-host hop)) - (aset hop 2 - (concat - (tramp-file-name-host hop) tramp-prefix-port-format - (number-to-string - (tramp-get-method-parameter - (tramp-file-name-method hop) 'tramp-default-port))))) - ;; Open the gateway connection. - (add-to-list - 'target-alist - (vector - (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil)) - ;; For the password prompt, we need the correct values. - ;; Therefore, we must remember the gateway vector. But we - ;; cannot do it as connection property, because it shouldn't - ;; be persistent. And we have no started process yet either. - (tramp-set-file-property (car target-alist) "" "gateway" hop))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while choices - (setq item (pop choices)) - (when - (or - (not - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-login-program)) - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-copy-program)) - (tramp-error - vec 'file-error - "Method `%s' is not supported for multi-hops." - (tramp-file-name-method item))))) - - ;; In case the host name is not used for the remote shell - ;; command, the user could be misguided by applying a random - ;; hostname. - (let* ((v (car target-alist)) - (method (tramp-file-name-method v)) - (host (tramp-file-name-host v))) - (unless - (or - ;; There are multi-hops. - (cdr target-alist) - ;; The host name is used for the remote shell command. - (member - '("%h") (tramp-get-method-parameter method 'tramp-login-args)) - ;; The host is local. We cannot use `tramp-local-host-p' - ;; here, because it opens a connection as well. - (string-match tramp-local-host-regexp host)) - (tramp-error - v 'file-error - "Host `%s' looks like a remote host, `%s' can only use the local host" - host method))) - - ;; Result. - target-alist)) - -(defun tramp-maybe-open-connection (vec) - "Maybe open a connection VEC. -Does not do anything if a connection is already open, but re-opens the -connection if a previous connection has died for some reason." - (catch 'uname-changed - (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name" nil)) - (process-environment (copy-sequence process-environment))) - - ;; If too much time has passed since last command was sent, look - ;; whether process is still alive. If it isn't, kill it. When - ;; using ssh, it can sometimes happen that the remote end has - ;; hung up but the local ssh client doesn't recognize this until - ;; it tries to send some data to the remote end. So that's why - ;; we try to send a command from time to time, then look again - ;; whether the process is really alive. - (condition-case nil - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) - p (processp p) (memq (process-status p) '(run open))) - (tramp-send-command vec "echo are you awake" t t) - (unless (and (memq (process-status p) '(run open)) - (tramp-wait-for-output p 10)) - ;; The error will be catched locally. - (tramp-error vec 'file-error "Awake did fail"))) - (file-error - (tramp-flush-connection-property vec) - (tramp-flush-connection-property p) - (delete-process p) - (setq p nil))) - - ;; New connection must be opened. - (unless (and p (processp p) (memq (process-status p) '(run open))) - - ;; We call `tramp-get-buffer' in order to get a debug buffer for - ;; messages from the beginning. - (tramp-get-buffer vec) - (with-progress-reporter - vec 3 - (if (zerop (length (tramp-file-name-user vec))) - (format "Opening connection for %s using %s" - (tramp-file-name-host vec) - (tramp-file-name-method vec)) - (format "Opening connection for %s@%s using %s" - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (tramp-file-name-method vec))) - - ;; Start new process. - (when (and p (processp p)) - (delete-process p)) - (setenv "TERM" tramp-terminal-type) - (setenv "LC_ALL" "C") - (setenv "PROMPT_COMMAND") - (setenv "PS1" tramp-initial-end-of-output) - (let* ((target-alist (tramp-compute-multi-hops vec)) - (process-connection-type tramp-process-connection-type) - (process-adaptive-read-buffering nil) - (coding-system-for-read nil) - ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process - (or process-name (tramp-buffer-name vec)) - (tramp-get-connection-buffer vec) - tramp-encoding-shell)))) - - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - - ;; Check whether process is alive. - (tramp-set-process-query-on-exit-flag p nil) - (tramp-barf-if-no-shell-prompt - p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell) - - ;; Now do all the connections as specified. - (while target-alist - (let* ((hop (car target-alist)) - (l-method (tramp-file-name-method hop)) - (l-user (tramp-file-name-user hop)) - (l-host (tramp-file-name-host hop)) - (l-port nil) - (login-program - (tramp-get-method-parameter - l-method 'tramp-login-program)) - (login-args - (tramp-get-method-parameter l-method 'tramp-login-args)) - (async-args - (tramp-get-method-parameter l-method 'tramp-async-args)) - (gw-args - (tramp-get-method-parameter l-method 'tramp-gw-args)) - (gw (tramp-get-file-property hop "" "gateway" nil)) - (g-method (and gw (tramp-file-name-method gw))) - (g-user (and gw (tramp-file-name-user gw))) - (g-host (and gw (tramp-file-name-host gw))) - (command login-program) - ;; We don't create the temporary file. In fact, - ;; it is just a prefix for the ControlPath option - ;; of ssh; the real temporary file has another - ;; name, and it is created and protected by ssh. - ;; It is also removed by ssh, when the connection - ;; is closed. - (tmpfile - (tramp-set-connection-property - p "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) - spec) - - ;; Add arguments for asynchrononous processes. - (when (and process-name async-args) - (setq login-args (append async-args login-args))) - - ;; Add gateway arguments if necessary. - (when (and gw gw-args) - (setq login-args (append gw-args login-args))) - - ;; Check for port number. Until now, there's no need - ;; for handling like method, user, host. - (when (string-match tramp-host-with-port-regexp l-host) - (setq l-port (match-string 2 l-host) - l-host (match-string 1 l-host))) - - ;; Set variables for computing the prompt for reading - ;; password. They can also be derived from a gateway. - (setq tramp-current-method (or g-method l-method) - tramp-current-user (or g-user l-user) - tramp-current-host (or g-host l-host)) - - ;; Replace login-args place holders. - (setq - l-host (or l-host "") - l-user (or l-user "") - l-port (or l-port "") - spec (format-spec-make - ?h l-host ?u l-user ?p l-port ?t tmpfile) - command - (concat - ;; We do not want to see the trailing local prompt in - ;; `start-file-process'. - (unless (memq system-type '(windows-nt)) "exec ") - command " " - (mapconcat - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) - login-args " ") - ;; Local shell could be a Windows COMSPEC. It - ;; doesn't know the ";" syntax, but we must exit - ;; always for `start-file-process'. "exec" does not - ;; work either. - (if (memq system-type '(windows-nt)) " && exit || exit"))) - - ;; Send the command. - (tramp-message vec 3 "Sending command `%s'" command) - (tramp-send-command vec command t t) - (tramp-process-actions p vec tramp-actions-before-shell 60) - (tramp-message - vec 3 "Found remote shell prompt on `%s'" l-host)) - ;; Next hop. - (setq target-alist (cdr target-alist))) - - ;; Make initial shell settings. - (tramp-open-connection-setup-interactive-shell p vec))))))) - -(defun tramp-send-command (vec command &optional neveropen nooutput) - "Send the COMMAND to connection VEC. -Erases temporary buffer before sending the command. If optional -arg NEVEROPEN is non-nil, never try to open the connection. This -is meant to be used from `tramp-maybe-open-connection' only. The -function waits for output unless NOOUTPUT is set." - (unless neveropen (tramp-maybe-open-connection vec)) - (let ((p (tramp-get-connection-process vec))) - (when (tramp-get-connection-property p "remote-echo" nil) - ;; We mark the command string that it can be erased in the output buffer. - (tramp-set-connection-property p "check-remote-echo" t) - (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (unless nooutput (tramp-wait-for-output p)))) - -(defun tramp-wait-for-output (proc &optional timeout) - "Wait for output from remote command." - (unless (buffer-live-p (process-buffer proc)) - (delete-process proc) - (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) - (with-current-buffer (process-buffer proc) - (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might - ;; be leading escape sequences, which must be ignored. - (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output))) - ;; Sometimes, the commands do not return a newline but a - ;; null byte before the shell prompt, for example "git - ;; ls-files -c -z ...". - (regexp1 (format "\\(^\\|\000\\)%s" regexp)) - (found (tramp-wait-for-regexp proc timeout regexp1))) - (if found - (let (buffer-read-only) - ;; A simple-minded busybox has sent " ^H" sequences. - ;; Delete them. - (goto-char (point-min)) - (when (re-search-forward - "^\\(.\b\\)+$" (tramp-compat-line-end-position) t) - (forward-line 1) - (delete-region (point-min) (point))) - ;; Delete the prompt. - (goto-char (point-max)) - (re-search-backward regexp nil t) - (delete-region (point) (point-max))) - (if timeout - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found in %d secs]]" - tramp-end-of-output timeout) - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found]]" tramp-end-of-output))) - ;; Return value is whether end-of-output sentinel was found. - found))) - -(defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) - "Run COMMAND and check its exit status. -Sends `echo $?' along with the COMMAND for checking the exit status. If -COMMAND is nil, just sends `echo $?'. Returns the exit status found. - -If the optional argument SUBSHELL is non-nil, the command is -executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." - (tramp-send-command - vec - (concat (if subshell "( " "") - command - (if command (if dont-suppress-err "; " " 2>/dev/null; ") "") - "echo tramp_exit_status $?" - (if subshell " )" ""))) - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-max)) - (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) - (tramp-error - vec 'file-error "Couldn't find exit status of `%s'" command)) - (skip-chars-forward "^ ") - (prog1 - (read (current-buffer)) - (let (buffer-read-only) (delete-region (match-beginning 0) (point-max)))))) - -(defun tramp-barf-unless-okay (vec command fmt &rest args) - "Run COMMAND, check exit status, throw error if exit status not okay. -Similar to `tramp-send-command-and-check' but accepts two more arguments -FMT and ARGS which are passed to `error'." - (unless (zerop (tramp-send-command-and-check vec command)) - (apply 'tramp-error vec 'file-error fmt args))) - -(defun tramp-send-command-and-read (vec command) - "Run COMMAND and return the output, which must be a Lisp expression. -In case there is no valid Lisp expression, it raises an error" - (tramp-barf-unless-okay vec command "`%s' returns with error" command) - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (condition-case nil - (prog1 (read (current-buffer)) - ;; Error handling. - (when (re-search-forward "\\S-" (tramp-compat-line-end-position) t) - (error nil))) - (error (tramp-error - vec 'file-error - "`%s' does not return a valid Lisp expression: `%s'" - command (buffer-string)))))) - ;; It seems that Tru64 Unix does not like it if long strings are sent ;; to it in one go. (This happens when sending the Perl ;; `file-attributes' implementation, for instance.) Therefore, we @@ -7791,181 +2852,6 @@ (setq pos (+ pos chunksize)))) (process-send-string p string))))) -(defun tramp-mode-string-to-int (mode-string) - "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." - (let* (case-fold-search - (mode-chars (string-to-vector mode-string)) - (owner-read (aref mode-chars 1)) - (owner-write (aref mode-chars 2)) - (owner-execute-or-setid (aref mode-chars 3)) - (group-read (aref mode-chars 4)) - (group-write (aref mode-chars 5)) - (group-execute-or-setid (aref mode-chars 6)) - (other-read (aref mode-chars 7)) - (other-write (aref mode-chars 8)) - (other-execute-or-sticky (aref mode-chars 9))) - (save-match-data - (logior - (cond - ((char-equal owner-read ?r) (tramp-octal-to-decimal "00400")) - ((char-equal owner-read ?-) 0) - (t (error "Second char `%c' must be one of `r-'" owner-read))) - (cond - ((char-equal owner-write ?w) (tramp-octal-to-decimal "00200")) - ((char-equal owner-write ?-) 0) - (t (error "Third char `%c' must be one of `w-'" owner-write))) - (cond - ((char-equal owner-execute-or-setid ?x) - (tramp-octal-to-decimal "00100")) - ((char-equal owner-execute-or-setid ?S) - (tramp-octal-to-decimal "04000")) - ((char-equal owner-execute-or-setid ?s) - (tramp-octal-to-decimal "04100")) - ((char-equal owner-execute-or-setid ?-) 0) - (t (error "Fourth char `%c' must be one of `xsS-'" - owner-execute-or-setid))) - (cond - ((char-equal group-read ?r) (tramp-octal-to-decimal "00040")) - ((char-equal group-read ?-) 0) - (t (error "Fifth char `%c' must be one of `r-'" group-read))) - (cond - ((char-equal group-write ?w) (tramp-octal-to-decimal "00020")) - ((char-equal group-write ?-) 0) - (t (error "Sixth char `%c' must be one of `w-'" group-write))) - (cond - ((char-equal group-execute-or-setid ?x) - (tramp-octal-to-decimal "00010")) - ((char-equal group-execute-or-setid ?S) - (tramp-octal-to-decimal "02000")) - ((char-equal group-execute-or-setid ?s) - (tramp-octal-to-decimal "02010")) - ((char-equal group-execute-or-setid ?-) 0) - (t (error "Seventh char `%c' must be one of `xsS-'" - group-execute-or-setid))) - (cond - ((char-equal other-read ?r) - (tramp-octal-to-decimal "00004")) - ((char-equal other-read ?-) 0) - (t (error "Eighth char `%c' must be one of `r-'" other-read))) - (cond - ((char-equal other-write ?w) (tramp-octal-to-decimal "00002")) - ((char-equal other-write ?-) 0) - (t (error "Nineth char `%c' must be one of `w-'" other-write))) - (cond - ((char-equal other-execute-or-sticky ?x) - (tramp-octal-to-decimal "00001")) - ((char-equal other-execute-or-sticky ?T) - (tramp-octal-to-decimal "01000")) - ((char-equal other-execute-or-sticky ?t) - (tramp-octal-to-decimal "01001")) - ((char-equal other-execute-or-sticky ?-) 0) - (t (error "Tenth char `%c' must be one of `xtT-'" - other-execute-or-sticky))))))) - -(defun tramp-convert-file-attributes (vec attr) - "Convert file-attributes ATTR generated by perl script, stat or ls. -Convert file mode bits to string and set virtual device number. -Return ATTR." - (when attr - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) - (list (floor (nth 4 attr) 65536) - (floor (mod (nth 4 attr) 65536))))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) - (list (floor (nth 5 attr) 65536) - (floor (mod (nth 5 attr) 65536))))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) - (list (floor (nth 6 attr) 65536) - (floor (mod (nth 6 attr) 65536))))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-match "^d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (unless (listp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (cons (floor (nth 10 attr) 65536) - (floor (mod (nth 10 attr) 65536))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec)) - attr)) - -(defun tramp-check-cached-permissions (vec access) - "Check `file-attributes' caches for VEC. -Return t if according to the cache access type ACCESS is known to -be granted." - (let ((result nil) - (offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3)))) - (dolist (suffix '("string" "integer") result) - (setq - result - (or - result - (let ((file-attr - (tramp-get-file-property - vec (tramp-file-name-localname vec) - (concat "file-attributes-" suffix) nil)) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil))) - (and - file-attr - (or - ;; Not a symlink - (eq t (car file-attr)) - (null (car file-attr))) - (or - ;; World accessible. - (eq access (aref (nth 8 file-attr) (+ offset 6))) - ;; User accessible and owned by user. - (and - (eq access (aref (nth 8 file-attr) offset)) - (equal remote-uid (nth 2 file-attr))) - ;; Group accessible and owned by user's - ;; principal group. - (and - (eq access (aref (nth 8 file-attr) (+ offset 3))) - (equal remote-gid (nth 3 file-attr))))))))))) - (defun tramp-get-inode (vec) "Returns the virtual inode number. If it doesn't exist, generate a new one." @@ -7992,199 +2878,6 @@ (list string (length tramp-devices)))) (cons -1 (nth 1 (assoc string tramp-devices))))) -(defun tramp-file-mode-from-int (mode) - "Turn an integer representing a file mode into an ls(1)-like string." - (let ((type (cdr (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) - (user (logand (lsh mode -6) 7)) - (group (logand (lsh mode -3) 7)) - (other (logand (lsh mode -0) 7)) - (suid (> (logand (lsh mode -9) 4) 0)) - (sgid (> (logand (lsh mode -9) 2) 0)) - (sticky (> (logand (lsh mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) - (concat type user group other))) - -(defun tramp-file-mode-permissions (perm suid suid-text) - "Convert a permission bitset into a string. -This is used internally by `tramp-file-mode-from-int'." - (let ((r (> (logand perm 4) 0)) - (w (> (logand perm 2) 0)) - (x (> (logand perm 1) 0))) - (concat (or (and r "r") "-") - (or (and w "w") "-") - (or (and suid x suid-text) ; suid, execute - (and suid (upcase suid-text)) ; suid, !execute - (and x "x") "-")))) ; !suid - -(defun tramp-decimal-to-octal (i) - "Return a string consisting of the octal digits of I. -Not actually used. Use `(format \"%o\" i)' instead?" - (cond ((< i 0) (error "Cannot convert negative number to octal")) - ((not (integerp i)) (error "Cannot convert non-integer to octal")) - ((zerop i) "0") - (t (concat (tramp-decimal-to-octal (/ i 8)) - (number-to-string (% i 8)))))) - -;; Kudos to Gerd Moellmann for this suggestion. -(defun tramp-octal-to-decimal (ostr) - "Given a string of octal digits, return a decimal number." - (let ((x (or ostr ""))) - ;; `save-match' is in `tramp-mode-string-to-int' which calls this. - (unless (string-match "\\`[0-7]*\\'" x) - (error "Non-octal junk in string `%s'" x)) - (string-to-number ostr 8))) - -(defun tramp-shell-case-fold (string) - "Converts STRING to shell glob pattern which ignores case." - (mapconcat - (lambda (c) - (if (equal (downcase c) (upcase c)) - (vector c) - (format "[%c%c]" (downcase c) (upcase c)))) - string - "")) - - -;; ------------------------------------------------------------ -;; -- Tramp file names -- -;; ------------------------------------------------------------ -;; Conversion functions between external representation and -;; internal data structure. Convenience functions for internal -;; data structure. - -(defun tramp-file-name-p (vec) - "Check, whether VEC is a Tramp object." - (and (vectorp vec) (= 4 (length vec)))) - -(defun tramp-file-name-method (vec) - "Return method component of VEC." - (and (tramp-file-name-p vec) (aref vec 0))) - -(defun tramp-file-name-user (vec) - "Return user component of VEC." - (and (tramp-file-name-p vec) (aref vec 1))) - -(defun tramp-file-name-host (vec) - "Return host component of VEC." - (and (tramp-file-name-p vec) (aref vec 2))) - -(defun tramp-file-name-localname (vec) - "Return localname component of VEC." - (and (tramp-file-name-p vec) (aref vec 3))) - -;; The user part of a Tramp file name vector can be of kind -;; "user%domain". Sometimes, we must extract these parts. -(defun tramp-file-name-real-user (vec) - "Return the user name of VEC without domain." - (save-match-data - (let ((user (tramp-file-name-user vec))) - (if (and (stringp user) - (string-match tramp-user-with-domain-regexp user)) - (match-string 1 user) - user)))) - -(defun tramp-file-name-domain (vec) - "Return the domain name of VEC." - (save-match-data - (let ((user (tramp-file-name-user vec))) - (and (stringp user) - (string-match tramp-user-with-domain-regexp user) - (match-string 2 user))))) - -;; The host part of a Tramp file name vector can be of kind -;; "host#port". Sometimes, we must extract these parts. -(defun tramp-file-name-real-host (vec) - "Return the host name of VEC without port." - (save-match-data - (let ((host (tramp-file-name-host vec))) - (if (and (stringp host) - (string-match tramp-host-with-port-regexp host)) - (match-string 1 host) - host)))) - -(defun tramp-file-name-port (vec) - "Return the port number of VEC." - (save-match-data - (let ((host (tramp-file-name-host vec))) - (and (stringp host) - (string-match tramp-host-with-port-regexp host) - (string-to-number (match-string 2 host)))))) - -(defun tramp-tramp-file-p (name) - "Return t if NAME is a string with Tramp file name syntax." - (save-match-data - (and (stringp name) (string-match tramp-file-name-regexp name)))) - -(defun tramp-find-method (method user host) - "Return the right method string to use. -This is METHOD, if non-nil. Otherwise, do a lookup in -`tramp-default-method-alist'." - (or method - (let ((choices tramp-default-method-alist) - lmethod item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or host "")) - (string-match (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) - lmethod) - tramp-default-method)) - -(defun tramp-find-user (method user host) - "Return the right user string to use. -This is USER, if non-nil. Otherwise, do a lookup in -`tramp-default-user-alist'." - (or user - (let ((choices tramp-default-user-alist) - luser item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) - luser) - tramp-default-user)) - -(defun tramp-find-host (method user host) - "Return the right host string to use. -This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." - (or (and (> (length host) 0) host) - tramp-default-host)) - -(defun tramp-dissect-file-name (name &optional nodefault) - "Return a `tramp-file-name' structure. -The structure consists of remote method, remote user, remote host -and localname (file name on remote host). If NODEFAULT is -non-nil, the file name parts are not expanded to their default -values." - (save-match-data - (let ((match (string-match (nth 0 tramp-file-name-structure) name))) - (unless match (error "Not a Tramp file name: %s" name)) - (let ((method (match-string (nth 1 tramp-file-name-structure) name)) - (user (match-string (nth 2 tramp-file-name-structure) name)) - (host (match-string (nth 3 tramp-file-name-structure) name)) - (localname (match-string (nth 4 tramp-file-name-structure) name))) - (when (member method '("multi" "multiu")) - (error - "`%s' method is no longer supported, see (info \"(tramp)Multi-hops\")" - method)) - (when host - (when (string-match tramp-prefix-ipv6-regexp host) - (setq host (replace-match "" nil t host))) - (when (string-match tramp-postfix-ipv6-regexp host) - (setq host (replace-match "" nil t host)))) - (if nodefault - (vector method user host localname) - (vector - (tramp-find-method method user host) - (tramp-find-user method user host) - (tramp-find-host method user host) - localname)))))) - (defun tramp-equal-remote (file1 file2) "Check, whether the remote parts of FILE1 and FILE2 are identical. The check depends on method, user and host name of the files. If @@ -8203,423 +2896,6 @@ (stringp (file-remote-p file2)) (string-equal (file-remote-p file1) (file-remote-p file2)))) -(defun tramp-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME." - (concat tramp-prefix-format - (when (not (zerop (length method))) - (concat method tramp-postfix-method-format)) - (when (not (zerop (length user))) - (concat user tramp-postfix-user-format)) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - tramp-postfix-host-format - (when localname localname))) - -(defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -It must not be a complete Tramp file name, but as long as there are -necessary only. This function will be used in file name completion." - (concat tramp-prefix-format - (when (not (zerop (length method))) - (concat method tramp-postfix-method-format)) - (when (not (zerop (length user))) - (concat user tramp-postfix-user-format)) - (when (not (zerop (length host))) - (concat - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host) - tramp-postfix-host-format)) - (when localname localname))) - -(defun tramp-make-copy-program-file-name (vec) - "Create a file name suitable to be passed to `rcp' and workalikes." - (let ((user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec)) - (localname (tramp-shell-quote-argument - (tramp-file-name-localname vec)))) - (if (not (zerop (length user))) - (format "%s@%s:%s" user host localname) - (format "%s:%s" host localname)))) - -(defun tramp-method-out-of-band-p (vec size) - "Return t if this is an out-of-band method, nil otherwise." - (and - ;; It shall be an out-of-band method. - (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) - ;; Either the file size is large enough, or (in rare cases) there - ;; does not exist a remote encoding. - (or (null tramp-copy-size-limit) - (> size tramp-copy-size-limit) - (null (tramp-get-inline-coding vec "remote-encoding" size))))) - -(defun tramp-local-host-p (vec) - "Return t if this points to the local host, nil otherwise." - ;; We cannot use `tramp-file-name-real-host'. A port is an - ;; indication for an ssh tunnel or alike. - (let ((host (tramp-file-name-host vec))) - (and - (stringp host) - (string-match tramp-local-host-regexp host) - ;; The method shall be applied to one of the shell file name - ;; handler. `tramp-local-host-p' is also called for "smb" and - ;; alike, where it must fail. - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-login-program) - ;; The local temp directory must be writable for the other user. - (file-writable-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - host - (tramp-compat-temporary-file-directory))) - ;; On some systems, chown runs only for root. - (or (zerop (user-uid)) - (zerop (tramp-get-remote-uid vec 'integer)))))) - -;; Variables local to connection. - -(defun tramp-get-remote-path (vec) - (with-connection-property - ;; When `tramp-own-remote-path' is in `tramp-remote-path', we - ;; cache the result for the session only. Otherwise, the result - ;; is cached persistently. - (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) - vec) - "remote-path" - (let* ((remote-path (copy-tree tramp-remote-path)) - (elt1 (memq 'tramp-default-remote-path remote-path)) - (elt2 (memq 'tramp-own-remote-path remote-path)) - (default-remote-path - (when elt1 - (condition-case nil - (tramp-send-command-and-read - vec "echo \\\"`getconf PATH`\\\"") - ;; Default if "getconf" is not available. - (error - (tramp-message - vec 3 - "`getconf PATH' not successful, using default value \"%s\"." - "/bin:/usr/bin") - "/bin:/usr/bin")))) - (own-remote-path - (when elt2 - (condition-case nil - (tramp-send-command-and-read vec "echo \\\"$PATH\\\"") - ;; Default if "getconf" is not available. - (error - (tramp-message - vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.") - nil))))) - - ;; Replace place holder `tramp-default-remote-path'. - (when elt1 - (setcdr elt1 - (append - (tramp-compat-split-string default-remote-path ":") - (cdr elt1))) - (setq remote-path (delq 'tramp-default-remote-path remote-path))) - - ;; Replace place holder `tramp-own-remote-path'. - (when elt2 - (setcdr elt2 - (append - (tramp-compat-split-string own-remote-path ":") - (cdr elt2))) - (setq remote-path (delq 'tramp-own-remote-path remote-path))) - - ;; Remove double entries. - (setq elt1 remote-path) - (while (consp elt1) - (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) - (setcar elt2 nil)) - (setq elt1 (cdr elt1))) - - ;; Remove non-existing directories. - (delq - nil - (mapcar - (lambda (x) - (and - (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - x)) - x)) - remote-path))))) - -(defun tramp-get-remote-tmpdir (vec) - (with-connection-property vec "tmp-directory" - (let ((dir (tramp-shell-quote-argument "/tmp"))) - (if (and (zerop - (tramp-send-command-and-check - vec (format "%s -d %s" (tramp-get-test-command vec) dir))) - (zerop - (tramp-send-command-and-check - vec (format "%s -w %s" (tramp-get-test-command vec) dir)))) - dir - (tramp-error vec 'file-error "Directory %s not accessible" dir))))) - -(defun tramp-get-ls-command (vec) - (with-connection-property vec "ls" - (tramp-message vec 5 "Finding a suitable `ls' command") - (or - (catch 'ls-found - (dolist (cmd '("ls" "gnuls" "gls")) - (let ((dl (tramp-get-remote-path vec)) - result) - (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) - ;; Check parameters. On busybox, "ls" output coloring is - ;; enabled by default sometimes. So we try to disable it - ;; when possible. $LS_COLORING is not supported there. - ;; Some "ls" versions are sensible wrt the order of - ;; arguments, they fail when "-al" is after the - ;; "--color=never" argument (for example on FreeBSD). - (when (zerop (tramp-send-command-and-check - vec (format "%s -lnd /" result))) - (when (zerop (tramp-send-command-and-check - vec (format - "%s --color=never -al /dev/null" result))) - (setq result (concat result " --color=never"))) - (throw 'ls-found result)) - (setq dl (cdr dl)))))) - (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) - -(defun tramp-get-ls-command-with-dired (vec) - (save-match-data - (with-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") - ;; Some "ls" versions are sensible wrt the order of arguments, - ;; they fail when "-al" is after the "--dired" argument (for - ;; example on FreeBSD). - (zerop (tramp-send-command-and-check - vec (format "%s --dired -al /dev/null" - (tramp-get-ls-command vec))))))) - -(defun tramp-get-test-command (vec) - (with-connection-property vec "test" - (tramp-message vec 5 "Finding a suitable `test' command") - (if (zerop (tramp-send-command-and-check vec "test 0")) - "test" - (tramp-find-executable vec "test" (tramp-get-remote-path vec))))) - -(defun tramp-get-test-nt-command (vec) - ;; Does `test A -nt B' work? Use abominable `find' construct if it - ;; doesn't. BSD/OS 4.0 wants the parentheses around the command, - ;; for otherwise the shell crashes. - (with-connection-property vec "test-nt" - (or - (progn - (tramp-send-command - vec (format "( %s / -nt / )" (tramp-get-test-command vec))) - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (when (looking-at (regexp-quote tramp-end-of-output)) - (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) - (progn - (tramp-send-command - vec - (format - "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}" - (tramp-get-test-command vec))) - "tramp_test_nt %s %s")))) - -(defun tramp-get-file-exists-command (vec) - (with-connection-property vec "file-exists" - (tramp-message vec 5 "Finding command to check if file exists") - (tramp-find-file-exists-command vec))) - -(defun tramp-get-remote-ln (vec) - (with-connection-property vec "ln" - (tramp-message vec 5 "Finding a suitable `ln' command") - (tramp-find-executable vec "ln" (tramp-get-remote-path vec)))) - -(defun tramp-get-remote-perl (vec) - (with-connection-property vec "perl" - (tramp-message vec 5 "Finding a suitable `perl' command") - (let ((result - (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec)) - (tramp-find-executable - vec "perl" (tramp-get-remote-path vec))))) - ;; We must check also for some Perl modules. - (when result - (with-connection-property vec "perl-file-spec" - (zerop - (tramp-send-command-and-check - vec (format "%s -e 'use File::Spec;'" result)))) - (with-connection-property vec "perl-cwd-realpath" - (zerop - (tramp-send-command-and-check - vec (format "%s -e 'use Cwd \"realpath\";'" result))))) - result))) - -(defun tramp-get-remote-stat (vec) - (with-connection-property vec "stat" - (tramp-message vec 5 "Finding a suitable `stat' command") - (let ((result (tramp-find-executable - vec "stat" (tramp-get-remote-path vec))) - tmp) - ;; Check whether stat(1) returns usable syntax. %s does not - ;; work on older AIX systems. - (when result - (setq tmp - ;; We don't want to display an error message. - (with-temp-message (or (current-message) "") - (condition-case nil - (tramp-send-command-and-read - vec (format "%s -c '(\"%%N\" %%s)' /" result)) - (error nil)))) - (unless (and (listp tmp) (stringp (car tmp)) - (string-match "^./.$" (car tmp)) - (integerp (cadr tmp))) - (setq result nil))) - result))) - -(defun tramp-get-remote-readlink (vec) - (with-connection-property vec "readlink" - (tramp-message vec 5 "Finding a suitable `readlink' command") - (let ((result (tramp-find-executable - vec "readlink" (tramp-get-remote-path vec)))) - (when (and result - ;; We don't want to display an error message. - (with-temp-message (or (current-message) "") - (condition-case nil - (zerop - (tramp-send-command-and-check - vec (format "%s --canonicalize-missing /" result))) - (error nil)))) - result)))) - -(defun tramp-get-remote-trash (vec) - (with-connection-property vec "trash" - (tramp-message vec 5 "Finding a suitable `trash' command") - (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) - -(defun tramp-get-remote-id (vec) - (with-connection-property vec "id" - (tramp-message vec 5 "Finding POSIX `id' command") - (or - (catch 'id-found - (let ((dl (tramp-get-remote-path vec)) - result) - (while (and dl (setq result (tramp-find-executable vec "id" dl t t))) - ;; Check POSIX parameter. - (when (zerop (tramp-send-command-and-check - vec (format "%s -u" result))) - (throw 'id-found result)) - (setq dl (cdr dl))))) - (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))) - -(defun tramp-get-remote-uid (vec id-format) - (with-connection-property vec (format "uid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -u%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) - -(defun tramp-get-remote-gid (vec id-format) - (with-connection-property vec (format "gid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -g%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) - -(defun tramp-get-local-uid (id-format) - (if (equal id-format 'integer) (user-uid) (user-login-name))) - -(defun tramp-get-local-gid (id-format) - (nth 3 (tramp-compat-file-attributes "~/" id-format))) - -;; Some predefined connection properties. -(defun tramp-get-inline-compress (vec prop size) - "Return the compress command related to PROP. -PROP is either `inline-compress' or `inline-decompress'. SIZE is -the length of the file to be compressed. - -If no corresponding command is found, nil is returned." - (when (and (integerp tramp-inline-compress-start-size) - (> size tramp-inline-compress-start-size)) - (with-connection-property vec prop - (tramp-find-inline-compress vec) - (tramp-get-connection-property vec prop nil)))) - -(defun tramp-get-inline-coding (vec prop size) - "Return the coding command related to PROP. -PROP is either `remote-encoding', `remode-decoding', -`local-encoding' or `local-decoding'. - -SIZE is the length of the file to be coded. Depending on SIZE, -compression might be applied. - -If no corresponding command is found, nil is returned. -Otherwise, either a string is returned which contains a `%s' mark -to be used for the respective input or output file; or a Lisp -function cell is returned to be applied on a buffer." - (let ((coding - (with-connection-property vec prop - (tramp-find-inline-encoding vec) - (tramp-get-connection-property vec prop nil))) - (prop1 (if (string-match "encoding" prop) - "inline-compress" "inline-decompress")) - compress) - ;; The connection property might have been cached. So we must send - ;; the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match "remote" prop)) - (let ((name (symbol-name coding))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value coding) name) - (setq coding name))) - (when coding - ;; Check for the `compress' command. - (setq compress (tramp-get-inline-compress vec prop1 size)) - ;; Return the value. - (cond - ((and compress (symbolp coding)) - (if (string-match "decompress" prop1) - `(lambda (beg end) - (,coding beg end) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (apply - 'call-process-region (point-min) (point-max) - (car (split-string ,compress)) t t nil - (cdr (split-string ,compress))))) - `(lambda (beg end) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (apply - 'call-process-region beg end - (car (split-string ,compress)) t t nil - (cdr (split-string ,compress)))) - (,coding (point-min) (point-max))))) - ((symbolp coding) - coding) - ((and compress (string-match "decoding" prop)) - (format "(%s | %s >%%s)" coding compress)) - (compress - (format "(%s <%%s | %s)" compress coding)) - ((string-match "decoding" prop) - (format "%s >%%s" coding)) - (t - (format "%s <%%s" coding)))))) - (defun tramp-get-method-parameter (method param) "Return the method parameter PARAM. If the `tramp-methods' entry does not exist, return nil." @@ -8632,27 +2908,26 @@ "Check, whether OPERATION runs a file name handler." ;; The file name handler is determined on base of either an ;; argument, `buffer-file-name', or `default-directory'. - (condition-case nil - (let* ((buffer-file-name "/") - (default-directory "/") - (fnha file-name-handler-alist) - (check-file-name-operation operation) - (file-name-handler-alist - (list - (cons "/" - (lambda (operation &rest args) - "Returns OPERATION if it is the one to be checked." - (if (equal check-file-name-operation operation) - operation - (let ((file-name-handler-alist fnha)) - (apply operation args)))))))) - (equal (apply operation args) operation)) - (error nil))) + (ignore-errors + (let* ((buffer-file-name "/") + (default-directory "/") + (fnha file-name-handler-alist) + (check-file-name-operation operation) + (file-name-handler-alist + (list + (cons "/" + (lambda (operation &rest args) + "Returns OPERATION if it is the one to be checked." + (if (equal check-file-name-operation operation) + operation + (let ((file-name-handler-alist fnha)) + (apply operation args)))))))) + (equal (apply operation args) operation)))) (unless (tramp-exists-file-name-handler 'make-auto-save-file-name) (defadvice make-auto-save-file-name (around tramp-advice-make-auto-save-file-name () activate) - "Invoke `tramp-handle-make-auto-save-file-name' for Tramp files." + "Invoke `tramp-*-handle-make-auto-save-file-name' for Tramp files." (if (tramp-tramp-file-p (buffer-file-name)) ;; We cannot call `tramp-handle-make-auto-save-file-name' ;; directly, because this would bypass the locking mechanism. @@ -8682,8 +2957,9 @@ ;; Permissions should be set always, because there might be an old ;; auto-saved file belonging to another original file. This could ;; be a security threat. - (set-file-modes buffer-auto-save-file-name - (or (file-modes bfn) (tramp-octal-to-decimal "0600")))))) + (set-file-modes + buffer-auto-save-file-name + (or (file-modes bfn) (tramp-compat-octal-to-decimal "0600")))))) (unless (and (featurep 'xemacs) (= emacs-major-version 21) @@ -8787,7 +3063,6 @@ (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - ;; Pacify byte-compiler with `symbol-function'. (cond ((and (fboundp 'subtract-time) (fboundp 'float-time)) (tramp-compat-funcall @@ -8863,6 +3138,7 @@ ;; CCC: This function should be rewritten so that ;; `shell-quote-argument' is not used. This way, we are safe from ;; changes in `shell-quote-argument'. +;;;###tramp-autoload (defun tramp-shell-quote-argument (s) "Similar to `shell-quote-argument', but groks newlines. Only works for Bourne-like shells." @@ -8888,112 +3164,42 @@ (defun tramp-unload-tramp () "Discard Tramp from loading remote files." (interactive) - ;; When Tramp is not loaded yet, its autoloads are still active. - (tramp-unload-file-name-handlers) ;; ange-ftp settings must be enabled. (tramp-compat-funcall 'tramp-ftp-enable-ange-ftp) - ;; Maybe its not loaded yet. - (condition-case nil - (unload-feature 'tramp 'force) - (error nil))) - -(when (and load-in-progress - (string-match "Loading tramp..." (or (current-message) ""))) - (message "Loading tramp...done")) + ;; Maybe it's not loaded yet. + (ignore-errors (unload-feature 'tramp 'force))) (provide 'tramp) ;;; TODO: -;; * Handle nonlocal exits such as C-g. -;; * But it would probably be better to use with-local-quit at the -;; place where it's actually needed: around any potentially -;; indefinitely blocking piece of code. In this case it would be -;; within Tramp around one of its calls to accept-process-output (or -;; around one of the loops that calls accept-process-output) -;; (Stefan Monnier). ;; * Rewrite `tramp-shell-quote-argument' to abstain from using ;; `shell-quote-argument'. ;; * In Emacs 21, `insert-directory' shows total number of bytes used ;; by the files in that directory. Add this here. ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) ;; * Make ffap.el grok Tramp filenames. (Eli Tziperman) -;; * Don't use globbing for directories with many files, as this is -;; likely to produce long command lines, and some shells choke on -;; long command lines. -;; * How to deal with MULE in `insert-file-contents' and `write-region'? ;; * abbreviate-file-name ;; * Better error checking. At least whenever we see something ;; strange when doing zerop, we should kill the process and start ;; again. (Greg Stark) -;; * Remove unneeded parameters from methods. -;; * Make it work for different encodings, and for different file name -;; encodings, too. (Daniel Pittman) -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; * When editing a remote CVS controlled file as a different user, VC -;; gets confused about the file locking status. Try to find out why -;; the workaround doesn't work. ;; * Username and hostname completion. ;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode-p'. ;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'. ;; Code is nearly identical. -;; * Allow out-of-band methods as _last_ multi-hop. Open a connection -;; until the last but one hop via `start-file-process'. Apply it -;; also for ftp and smb. -;; * WIBNI if we had a command "trampclient"? If I was editing in -;; some shell with root priviledges, it would be nice if I could -;; just call -;; trampclient filename.c -;; as an editor, and the _current_ shell would connect to an Emacs -;; server and would be used in an existing non-priviledged Emacs -;; session for doing the editing in question. -;; That way, I need not tell Emacs my password again and be afraid -;; that it makes it into core dumps or other ugly stuff (I had Emacs -;; once display a just typed password in the context of a keyboard -;; sequence prompt for a question immediately following in a shell -;; script run within Emacs -- nasty). -;; And if I have some ssh session running to a different computer, -;; having the possibility of passing a local file there to a local -;; Emacs session (in case I can arrange for a connection back) would -;; be nice. -;; Likely the corresponding Tramp server should not allow the -;; equivalent of the emacsclient -eval option in order to make this -;; reasonably unproblematic. And maybe trampclient should have some -;; way of passing credentials, like by using an SSL socket or -;; something. (David Kastrup) -;; * Reconnect directly to a compliant shell without first going -;; through the user's default shell. (Pete Forman) ;; * Make `tramp-default-user' obsolete. -;; * How can I interrupt the remote process with a signal -;; (interrupt-process seems not to work)? (Markus Triska) -;; * Avoid the local shell entirely for starting remote processes. If -;; so, I think even a signal, when delivered directly to the local -;; SSH instance, would correctly be propagated to the remote process -;; automatically; possibly SSH would have to be started with -;; "-t". (Markus Triska) -;; * It makes me wonder if tramp couldn't fall back to ssh when scp -;; isn't on the remote host. (Mark A. Hershberger) -;; * Use lsh instead of ssh. (Alfred M. Szmidt) ;; * Implement a general server-local-variable mechanism, as there are ;; probably other variables that need different values for different ;; servers too. The user could then configure a variable (such as ;; tramp-server-local-variable-alist) to define any such variables ;; that they need to, which would then be let bound as appropriate ;; in tramp functions. (Jason Rumney) -;; * Optimize out-of-band copying, when both methods are scp-like (not -;; rsync). -;; * Keep a second connection open for out-of-band methods like scp or -;; rsync. ;; * IMHO, it's a drawback that currently Tramp doesn't support ;; Unicode in Dired file names by default. Is it possible to ;; improve Tramp to set LC_ALL to "C" only for commands where Tramp ;; expects English? Or just to set LC_MESSAGES to "C" if Tramp ;; expects only English messages? (Juri Linkov) ;; * Make shadowfile.el grok Tramp filenames. (Bug#4526, Bug#4846) -;; * Load Tramp subpackages only when needed. (Bug#1529, Bug#5448, Bug#5705) -;; * Try telnet+curl as new method. It might be useful for busybox, -;; without built-in uuencode/uudecode. ;; * Load ~/.emacs_SHELLNAME on the remote host for `shell'. ;; * I was wondering it it would be possible to use tramp even if I'm ;; actually using sshfs. But when I launch a command I would like
--- a/lisp/net/trampver.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/net/trampver.el Wed Sep 22 15:46:51 2010 +0900 @@ -31,16 +31,29 @@ ;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; ;; should be changed only there. -(defconst tramp-version "2.1.19" +;;;###tramp-autoload +(defconst tramp-version "2.2.0-pre" "This version of Tramp.") +;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") ;; Check for (X)Emacs version. -(let ((x (if (or (>= emacs-major-version 22) (and (featurep 'xemacs) (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" (format "Tramp 2.1.19 is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) +(let ((x (if (or (>= emacs-major-version 22) + (and (featurep 'xemacs) + (= emacs-major-version 21) + (>= emacs-minor-version 4))) + "ok" + (format "Tramp 2.2.0-pre is not fit for %s" + (when (string-match "^.*$" (emacs-version)) + (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'trampver 'force))) + (provide 'trampver) ;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1
--- a/lisp/notifications.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/notifications.el Wed Sep 22 15:46:51 2010 +0900 @@ -42,6 +42,9 @@ (require 'dbus) +(defconst notifications-specification-version "1.1" + "The version of the Desktop Notifications Specification implemented.") + (defconst notifications-application-name "Emacs" "Default application name.") @@ -151,7 +154,14 @@ :image-data This is a raw data image format which describes the width, height, rowstride, has alpha, bits per sample, channels and image data respectively. + :image-path This is represented either as a URI (file:// is the + only URI schema supported right now) or a name + in a freedesktop.org-compliant icon theme. :sound-file The path to a sound file to play when the notification pops up. + :sound-name A themeable named sound from the freedesktop.org sound naming + specification to play when the notification pops up. + Similar to icon-name,only for sounds. An example would + be \"message-new-instant\". :suppress-sound Causes the server to suppress playing any sounds, if it has that ability. :x Specifies the X location on the screen that the notification @@ -186,7 +196,9 @@ (category (plist-get params :category)) (desktop-entry (plist-get params :desktop-entry)) (image-data (plist-get params :image-data)) + (image-path (plist-get params :image-path)) (sound-file (plist-get params :sound-file)) + (sound-name (plist-get params :sound-name)) (suppress-sound (plist-get params :suppress-sound)) (x (plist-get params :x)) (y (plist-get params :y)) @@ -211,10 +223,18 @@ (add-to-list 'hints `(:dict-entry "image_data" (:variant :struct ,image-data)) t)) + (when image-path + (add-to-list 'hints `(:dict-entry + "image_path" + (:variant :string ,image-path)) t)) (when sound-file (add-to-list 'hints `(:dict-entry "sound-file" (:variant :string ,sound-file)) t)) + (when sound-name + (add-to-list 'hints `(:dict-entry + "sound-name" + (:variant :string ,sound-name)) t)) (when suppress-sound (add-to-list 'hints `(:dict-entry "suppress-sound"
--- a/lisp/nxml/TODO Wed Sep 08 12:55:57 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ -* High priority - -** Command to insert an element template, including all required -attributes and child elements. When there's a choice of elements -possible, we could insert a comment, and put an overlay on that -comment that makes it behave like a button with a pop-up menu to -select the appropriate choice. - -** Command to tag a region. With a schema should complete using legal -tags, but should work without a schema as well. - -** Provide a way to conveniently rename an element. With a schema should -complete using legal tags, but should work without a schema as well. - -* Outlining - -** Implement C-c C-o C-q. - -** Install pre/post command hook for moving out of invisible section. - -** Put a modify hook on invisible sections that expands them. - -** Integrate dumb folding somehow. - -** An element should be able to be its own heading. - -** Optimize to avoid complete buffer scan on each command. - -** Make it work with HTML-style headings (i.e. level indicated by -name of heading element rather than depth of section nesting). - -** Recognize root element as a section provided it has a title, even -if it doesn't match section-element-name-regex. - -** Support for incremental search automatically making hidden text -visible. - -** Allow title to be an attribute. - -** Command that says to recognize the tag at point as a section/heading. - -** Explore better ways to determine when an element is a section -or a heading. - -** rng-next-error needs to either ignore invisible portion or reveal it -(maybe use isearch oriented text properties). - -** Errors within hidden section should be highlighted by underlining the -ellipsis. - -** Make indirect buffers work. - -** How should nxml-refresh outline recover from non well-formed tags? - -** Hide tags in title elements? - -** Use overlays instead of text properties for holding outline state? -Necessary for indirect buffers to work? - -** Allow an outline to go in the speedbar. - -** Split up outlining manual section into subsections. - -** More detail in the manual about each outlining command. - -** More menu entries for hiding/showing? - -** Indication of many lines have been hidden? - -* Locating schemas - -** Should rng-validate-mode give the user an opportunity to specify a -schema if there is currently none? Or should it at least give a hint -to the user how to specify a non-vacuous schema? - -** Support for adding new schemas to schema-locating files. Add -documentElement and namespace elements. - -** C-c C-w should be able to report current type id. - -** Implement doctypePublicId. - -** Implement typeIdBase. - -** Implement typeIdProcessingInstruction. - -** Support xml:base. - -** Implement group. - -** Find preferred prefix from schema-locating files. Get rid of -rng-preferred-prefix-alist. - -** Inserting document element with vacuous schema should complete using -document elements declared in schema locating files, and set schema -appropriately. - -** Add a ruleType attribute to the <include> element? - -** Allow processing instruction in prolog to contain the compact syntax -schema directly. - -** Use RDDL to locate a schema based on the namespace URI. - -** Should not prompt to add redundant association to schema locating -file. - -** Command to reload current schema. - -* Schema-sensitive features - -** Should filter dynamic markup possibilities using schema validity, by -adding hook to nxml-mode. - -** Dynamic markup word should (at least optionally) be able to look in -other buffers that are using nxml-mode. - -** Should clicking on Invalid move to next error if already on an error? - -** Take advantage of a:documentation. Needs change to schema format. - -** Provide feasible validation (as in Jing) toggle. - -** Save the validation state as a property on the error overlay to enable -more detailed diagnosis. - -** Provide an Error Summary buffer showing all the validation errors. - -** Pop-up menu. What is useful? Tag a region (should be greyed out if -the region is not balanced). Suggestions based on error messages. - -** Have configurable list of namespace URIs so that we can provide -namespace URI completion on extension elements or with schema-less -documents. - -** Allow validation to handle XInclude. - -** ID/IDREF support. - -* Completion - -** Make it work with icomplete. Only use a function to complete when -some of the possible names have undeclared namespaces. - -** How should C-return in mixed text work? - -** When there's a vacuous schema, C-return after < will insert the -end-tag. Is this a bug or a feature? - -** After completing start-tag, ensure we don't get unhelpful message -from validation - -** Syntax table for completion. - -** Should complete start-tag name with a space if namespace attributes -are required. - -** When completing start-tag name with no prefix and it doesn't match -should try to infer namespace from local name. - -** Should completion pay attention to characters after point? If so, -how? - -** When completing start-tag name, add required atts if only one required -attribute. - -** When completing attribute name, add attribute value if only one value -is possible. - -** After attribute-value completion, insert space after close delimiter -if more attributes are required. - -** Complete on enumerated data values in elements. - -** When in context that allows only elements, should get tag -completion without having to type < first. - -** When immediately after start-tag name, and name is valid and not -prefix of any other name, should C-return complete on attribute names? - -** When completing attributes, more consistent to ignore all attributes -after point. - -** Inserting attribute value completions needs to be sensitive to what -delimiter is used so that it quotes the correct character. - -** Complete on encoding-names in XML decl. - -** Complete namespace declarations by searching for all namespaces -mentioned in the schema. - -* Well-formed XML support - -** Deal better with Mule-UCS - -** Deal with UTF-8 BOM when reading. - -** Complete entity names. - -** Provide some support for entity names for MathML. - -** Command to repeat the last tag. - -** Support for changing between character references and characters. -Need to check that context is one in which character references are -allowed. xmltok prolog parsing will need to distinguish parameter -literals from other kinds of literal. - -** Provide a comment command to bind to M-; that works better than the -normal one. - -** Make indenting in a multi-line comment work. - -** Structure view. Separate buffer displaying element tree. Be able to -navigate from structure view to document and vice-versa. - -** Flash matching >. - -** Smart selection command that selects increasingly large syntactically -coherent chunks of XML. If point is in an attribute value, first -select complete value; then if command is repeated, select value plus -delimiters, then select attribute name as well, then complete -start-tag, then complete element, then enclosing element, etc. - -** ispell integration. - -** Block-level items in mixed content should be indented, e.g: - <para>This is list: - <ul> - <li>item</li> - -** Provide option to indent like this: - -** <para>This is a paragraph - occupying multiple lines.</para> - -** Option to add make a / that closes a start-tag electrically insert a -space for the XHTML guys. - -** C-M-q should work. - -* Datatypes - -** Figure out workaround for CJK characters with regexps. - -** Does category C contain Cn? - -** Do ENTITY datatype properly. - -* XML Parsing Library - -** Parameter entity parsing option, nil (never), t (always), -unless-standalone (unless standalone="yes" in XML declaration). - -** When a file is currently being edited, there should be an option to -use its buffer instead of the on-disk copy. - -* Handling all XML features - -** Provide better support for editing external general parsed entities. -Perhaps provide a way to force ignoring undefined entities; maybe turn -this on automatically with <?xml encoding=""?> (with no version -pseudo-att). - -** Handle internal general entity declarations containing elements. - -** Handle external general entity declarations. - -** Handle default attribute declarations in internal subset. - -** Handle parameter entities (including DTD). - -* RELAX NG - -** Do complete schema checking, at least optionally. - -** Detect include/external loops during schema parse. - -** Coding system detection for schemas. Should use utf-8/utf-16 per the -spec. But also need to allow encodings other than UTF-8/16 to support -CJK charsets that Emacs cannot represent in Unicode. - -* Catching XML errors - -** Check public identifiers. - -** Check default attribute values. - -* Performance - -** Explore whether overlay-recenter can cure overlays performance -problems. - -** Cache schemas. Need to have list of files and mtimes. - -** Make it possible to reduce rng-validate-chunk-size significantly, -perhaps to 500 bytes, without bad performance impact: don't do -redisplay on every chunk; pass continue functions on other uses of -rng-do-some-validation. - -** Cache after first tag. - -** Introduce a new name class that is a choice between names (so that -we can use member) - -** intern-choice should simplify after patterns with same 1st/2nd args - -** Large numbers of overlays slow things down dramatically. Represent -errors using text properties. This implies we cannot incrementally -keep track of the number of errors, in order to determine validity. -Instead, when validation completes, scan for any characters with an -error text property; this seems to be fast enough even with large -buffers. Problem with error at end of buffer, where there's no -character; need special variable for this. Need to merge face from -font-lock with the error face: use :inherit attribute with list of two -faces. How do we avoid making rng-valid depend on nxml-mode? - -* Error recovery - -** Don't stop at newline in looking for close of start-tag. - -** Use indentation to guide recovery from mismatched end-tags - -** Don't keep parsing when currently not well-formed but previously -well-formed - -** Try to recover from a bad start-tag by popping an open element if -there was a mismatched end-tag unaccounted for. - -** Try to recover from a bad start-tag open on the hypothesis that there -was an error in the namespace URI. - -** Better recovery from ill-formed XML declarations. - -* Useability improvements - -** Should print a "Parsing..." message during long movements. - -** Provide better position for reference to undefined pattern error. - -** Put Well-formed in the mode-line when validating against any-content. - -** Trim marking of illegal data for leading and trailing whitespace. - -** Show Invalid status as soon as we are sure it's invalid, rather than -waiting for everything to be completely up to date. - -** When narrowed, Valid or Invalid status should probably consider only -validity of narrowed region. - -* Bug fixes - -** Need to give an error for a document like: <foo/><![CDATA[ ]]> - -** Make nxml-forward-balanced-item work better for the prolog. - -** Make filling and indenting comments work in the prolog. - -** Should delete RNC Input buffers. - -** Figure out what regex use for NCName and use it consistently, - -** Should have not-well-formed tokens in ref. - -** Require version in XML declaration? Probably not because prevents -use for external parsed entities. At least forbid standalone -without version. - -** Reject schema that compiles to rng-not-allowed-ipattern. - -** Move point backwards on schema parse error so that it's on the right token. - -* Internal - -** Use rng-quote-string consistently. - -** Use parsing library for XML to texinfo conversion. - -** Rename xmltok.el to nxml-token.el. Use nxml-t- prefix instead of -xmltok-. Change nxml-t-type to nxml-t-token-type, nxml-t-start to -nxml-t-token-start. - -** Can we set fill-prefix to nil and rely on indenting? - -** xmltok should make available replacement text of entities containing -elements - -** In rng-valid, instead of using modification-hooks and -insert-behind-hooks on dependent overlays, use same technique as -nxml-mode. - -** Port to XEmacs. Issues include: Unicode (XEmacs seems to be based on -Mule-UCS); overlays/text properties vs extents; absence of -fontification-functions hook. - -* Fontification - -** Allow face to depend on element qname, attribute qname, attribute -value. Use list with pairs of (R . F), where R specifies regexps and -F specifies faces. How can this list be made to depend on the -document type? - -* Other - -** Support RELAX NG XML syntax (use XML parsing library). - -** Support W3C XML Schema (use XML parsing library). - -** Command to infer schema from current document (like trang). - -* Schemas - -** XSLT schema should take advantage of RELAX NG to express cooccurrence -constraints on attributes (e.g. xsl:template). - -* Documentation - -** Move material from README to manual. - -** Document encodings. - -* Notes - -** How can we allow an error to be displayed on a different token from -where it is detected? In particular, for a missing closing ">" we -will need to display it at the beginning of the following token. At -the moment, when we parse the following token the error overlay will -get cleared. - -** How should rng-goto-next-error deal with narrowing? - -** Perhaps should merge errors having same start position even if they -have different ends. - -** How to handle surrogates? One possibility is to be compatible with -utf8.e: represent as sequence of 4 chars. But utf-16 is incompatible -with this. - -** Should we distinguish well-formedness errors from invalidity errors? -(I think not: we may want to recover from a bad start-tag by implying -an end-tag.) - -** Seems to be a bug with Emacs, where a mouse movement that causes -help-echo text to appear counts as pending input but does not cause -idle timer to be restarted. - -** Use XML to represent this file. - -** I had a TODO which said simply "split-string". What did I mean? - -** Investigate performance on large files all on one line. - -* Issues for Emacs versions >= 22 - -** Take advantage of UTF-8 CJK support. - -** Supply a next-error-function. - -** Investigate this NEWS item "Emacs now tries to set up buffer coding -systems for HTML/XML files automatically." - -** Take advantage of the pointer text property. - -** Leverage char-displayable-p. - -Local variables: -mode: outline -end:
--- a/lisp/obsolete/old-whitespace.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/obsolete/old-whitespace.el Wed Sep 22 15:46:51 2010 +0900 @@ -725,9 +725,8 @@ (setq bufname (cadr thiselt)) (setq buf (get-buffer bufname)) (if (buffer-live-p buf) - (save-excursion + (with-current-buffer bufname ;;(message "buffer %s live" bufname) - (set-buffer bufname) (if whitespace-mode (progn ;;(message "checking for whitespace in %s" bufname) @@ -788,7 +787,7 @@ (defun whitespace-unload-function () "Unload the whitespace library." - (if (unintern "whitespace-unload-hook") + (if (unintern "whitespace-unload-hook" obarray) ;; if whitespace-unload-hook is defined, let's get rid of it ;; and recursively call `unload-feature' (progn (unload-feature 'whitespace) t)
--- a/lisp/org/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/org/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1163,7 +1163,7 @@ (org-agenda-bulk-remove-overlays): Use the normal overlay API. * org-freemind.el (org-freemind-from-org-mode-node) - (org-freemind-from-org-mode, ) + (org-freemind-from-org-mode) (org-freemind-from-org-sparse-tree, org-freemind-to-org-mode): Use interactive-p instead of called-interactively, because this is backward compatible with older Emacsen I still support.. @@ -2616,7 +2616,7 @@ 2010-02-15 Chong Yidong <cyd@stupidchicken.com> * org-freemind.el (org-freemind-from-org-mode-node) - (org-freemind-from-org-mode, ) + (org-freemind-from-org-mode) (org-freemind-from-org-sparse-tree, org-freemind-to-org-mode): Pass arg to called-interactively-p.
--- a/lisp/progmodes/ada-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/ada-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -834,10 +834,7 @@ ;; ;; On Emacs, this is done through the `syntax-table' text property. The ;; corresponding action is applied automatically each time the buffer -;; changes. If `font-lock-mode' is enabled (the default) the action is -;; set up by `font-lock-syntactic-keywords'. Otherwise, we do it -;; manually in `ada-after-change-function'. The proper method is -;; installed by `ada-handle-syntax-table-properties'. +;; changes via syntax-propertize-function. ;; ;; on XEmacs, the `syntax-table' property does not exist and we have to use a ;; slow advice to `parse-partial-sexp' to do the same thing. @@ -937,6 +934,12 @@ (insert (caddar change)) (setq change (cdr change))))))) +(unless (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + ;; Before `syntax-propertize', we had to use font-lock to apply syntax-table + ;; properties, and in some cases we even had to do it manually (in + ;; `ada-after-change-function'). `ada-handle-syntax-table-properties' + ;; decides which method to use. + (defun ada-set-syntax-table-properties () "Assign `syntax-table' properties in accessible part of buffer. In particular, character constants are said to be strings, #...# @@ -991,6 +994,8 @@ ;; Take care of `syntax-table' properties manually. (ada-initialize-syntax-table-properties))) +) ;;(not (fboundp 'syntax-propertize)) + ;;------------------------------------------------------------------ ;; Testing the grammatical context ;;------------------------------------------------------------------ @@ -1118,7 +1123,8 @@ ;;;###autoload (defun ada-mode () - "Ada mode is the major mode for editing Ada code." + "Ada mode is the major mode for editing Ada code. +\\{ada-mode-map}" (interactive) (kill-all-local-variables) @@ -1161,9 +1167,9 @@ (set (make-local-variable 'comment-padding) 0) (set (make-local-variable 'parse-sexp-lookup-properties) t)) - (set 'case-fold-search t) + (setq case-fold-search t) (if (boundp 'imenu-case-fold-search) - (set 'imenu-case-fold-search t)) + (setq imenu-case-fold-search t)) (set (make-local-variable 'fill-paragraph-function) 'ada-fill-comment-paragraph) @@ -1186,8 +1192,13 @@ '(ada-font-lock-keywords nil t ((?\_ . "w") (?# . ".")) - beginning-of-line - (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + beginning-of-line)) + + (if (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-via-font-lock ada-font-lock-syntactic-keywords)) + (set (make-local-variable 'font-lock-syntactic-keywords) + ada-font-lock-syntactic-keywords)) ;; Set up support for find-file.el. (set (make-local-variable 'ff-other-file-alist) @@ -1322,22 +1333,24 @@ ;; To be run after the hook, in case the user modified ;; ada-fill-comment-prefix - (make-local-variable 'comment-start) - (if ada-fill-comment-prefix - (set 'comment-start ada-fill-comment-prefix) - (set 'comment-start "-- ")) + ;; FIXME: if the user modified ada-fill-comment-prefix in his .emacs + ;; then it was already available before running the hook, and if he + ;; modifies it in the hook, he might as well modify comment-start instead. + (set (make-local-variable 'comment-start) (or ada-fill-comment-prefix "-- ")) ;; Run this after the hook to give the users a chance to activate ;; font-lock-mode - (unless (featurep 'xemacs) + (unless (or (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + (featurep 'xemacs)) (ada-initialize-syntax-table-properties) (add-hook 'font-lock-mode-hook 'ada-handle-syntax-table-properties nil t)) ;; the following has to be done after running the ada-mode-hook ;; because users might want to set the values of these variable ;; inside the hook - + ;; FIXME: it might even be set later on via file-local vars, no? + ;; so maybe ada-keywords should be set lazily. (cond ((eq ada-language-version 'ada83) (setq ada-keywords ada-83-keywords)) ((eq ada-language-version 'ada95) @@ -1397,25 +1410,21 @@ The new word is added to the first file in `ada-case-exception-file'. The standard casing rules will no longer apply to this word." (interactive) - (let ((previous-syntax-table (syntax-table)) - file-name - ) - - (cond ((stringp ada-case-exception-file) - (setq file-name ada-case-exception-file)) - ((listp ada-case-exception-file) - (setq file-name (car ada-case-exception-file))) - (t - (error (concat "No exception file specified. " - "See variable ada-case-exception-file")))) - - (set-syntax-table ada-mode-symbol-syntax-table) + (let ((file-name + (cond ((stringp ada-case-exception-file) + ada-case-exception-file) + ((listp ada-case-exception-file) + (car ada-case-exception-file)) + (t + (error (concat "No exception file specified. " + "See variable ada-case-exception-file")))))) + (unless word - (save-excursion - (skip-syntax-backward "w") - (setq word (buffer-substring-no-properties - (point) (save-excursion (forward-word 1) (point)))))) - (set-syntax-table previous-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table + (save-excursion + (skip-syntax-backward "w") + (setq word (buffer-substring-no-properties + (point) (save-excursion (forward-word 1) (point))))))) ;; Reread the exceptions file, in case it was modified by some other, (ada-case-read-exceptions-from-file file-name) @@ -1425,11 +1434,9 @@ (if (and (not (equal ada-case-exception '())) (assoc-string word ada-case-exception t)) (setcar (assoc-string word ada-case-exception t) word) - (add-to-list 'ada-case-exception (cons word t)) - ) - - (ada-save-exceptions-to-file file-name) - )) + (add-to-list 'ada-case-exception (cons word t))) + + (ada-save-exceptions-to-file file-name))) (defun ada-create-case-exception-substring (&optional word) "Define the substring WORD as an exception for the casing system. @@ -1464,7 +1471,7 @@ (modify-syntax-entry ?_ "." (syntax-table)) (save-excursion (skip-syntax-backward "w") - (set 'word (buffer-substring-no-properties + (setq word (buffer-substring-no-properties (point) (save-excursion (forward-word 1) (point)))))) (modify-syntax-entry ?_ (make-string 1 underscore-syntax) @@ -1633,37 +1640,30 @@ (interactive "P") (if ada-auto-case - (let ((lastk last-command-event) - (previous-syntax-table (syntax-table))) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - (cond ((or (eq lastk ?\n) - (eq lastk ?\r)) - ;; horrible kludge - (insert " ") - (ada-adjust-case) - ;; horrible dekludge - (delete-char -1) - ;; some special keys and their bindings - (cond - ((eq lastk ?\n) - (funcall ada-lfd-binding)) - ((eq lastk ?\r) - (funcall ada-ret-binding)))) - ((eq lastk ?\C-i) (ada-tab)) - ;; Else just insert the character - ((self-insert-command (prefix-numeric-value arg)))) - ;; if there is a keyword in front of the underscore - ;; then it should be part of an identifier (MH) - (if (eq lastk ?_) - (ada-adjust-case t) - (ada-adjust-case)) - ) - ;; Restore the syntax table - (set-syntax-table previous-syntax-table)) - ) + (let ((lastk last-command-event)) + + (with-syntax-table ada-mode-symbol-syntax-table + (cond ((or (eq lastk ?\n) + (eq lastk ?\r)) + ;; horrible kludge + (insert " ") + (ada-adjust-case) + ;; horrible dekludge + (delete-char -1) + ;; some special keys and their bindings + (cond + ((eq lastk ?\n) + (funcall ada-lfd-binding)) + ((eq lastk ?\r) + (funcall ada-ret-binding)))) + ((eq lastk ?\C-i) (ada-tab)) + ;; Else just insert the character + ((self-insert-command (prefix-numeric-value arg)))) + ;; if there is a keyword in front of the underscore + ;; then it should be part of an identifier (MH) + (if (eq lastk ?_) + (ada-adjust-case t) + (ada-adjust-case)))) ;; Else, no auto-casing (cond @@ -1672,10 +1672,10 @@ ((eq last-command-event ?\r) (funcall ada-ret-binding)) (t - (self-insert-command (prefix-numeric-value arg)))) - )) + (self-insert-command (prefix-numeric-value arg)))))) (defun ada-activate-keys-for-case () + ;; FIXME: Use post-self-insert-hook instead of changing key bindings. "Modify the key bindings for all the keys that should readjust the casing." (interactive) ;; Save original key-bindings to allow swapping ret/lfd @@ -1735,44 +1735,41 @@ (let ((begin nil) (end nil) (keywordp nil) - (attribp nil) - (previous-syntax-table (syntax-table))) + (attribp nil)) (message "Adjusting case ...") - (unwind-protect - (save-excursion - (set-syntax-table ada-mode-symbol-syntax-table) - (goto-char to) - ;; - ;; loop: look for all identifiers, keywords, and attributes - ;; - (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) - (setq end (match-end 1)) - (setq attribp - (and (> (point) from) - (save-excursion - (forward-char -1) - (setq attribp (looking-at "'.[^']"))))) - (or - ;; do nothing if it is a string or comment - (ada-in-string-or-comment-p) - (progn - ;; - ;; get the identifier or keyword or attribute - ;; - (setq begin (point)) - (setq keywordp (looking-at ada-keywords)) - (goto-char end) - ;; - ;; casing according to user-option - ;; - (if attribp - (funcall ada-case-attribute -1) - (if keywordp - (funcall ada-case-keyword -1) - (ada-adjust-case-identifier))) - (goto-char begin)))) - (message "Adjusting case ... Done")) - (set-syntax-table previous-syntax-table)))) + (with-syntax-table ada-mode-symbol-syntax-table + (save-excursion + (goto-char to) + ;; + ;; loop: look for all identifiers, keywords, and attributes + ;; + (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) + (setq end (match-end 1)) + (setq attribp + (and (> (point) from) + (save-excursion + (forward-char -1) + (setq attribp (looking-at "'.[^']"))))) + (or + ;; do nothing if it is a string or comment + (ada-in-string-or-comment-p) + (progn + ;; + ;; get the identifier or keyword or attribute + ;; + (setq begin (point)) + (setq keywordp (looking-at ada-keywords)) + (goto-char end) + ;; + ;; casing according to user-option + ;; + (if attribp + (funcall ada-case-attribute -1) + (if keywordp + (funcall ada-case-keyword -1) + (ada-adjust-case-identifier))) + (goto-char begin)))) + (message "Adjusting case ... Done"))))) (defun ada-adjust-case-buffer () "Adjust the case of all words in the whole buffer. @@ -1803,46 +1800,39 @@ (let ((begin nil) (end nil) (delend nil) - (paramlist nil) - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "Not in parameter list")) - - ;; find start of current parameter-list - (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) - (down-list 1) - (backward-char 1) - (setq begin (point)) - - ;; find end of parameter-list - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - (insert "\n") - - ;; find end of last parameter-declaration - (forward-comment -1000) - (setq end (point)) - - ;; build a list of all elements of the parameter-list - (setq paramlist (ada-scan-paramlist (1+ begin) end)) - - ;; delete the original parameter-list - (delete-region begin delend) - - ;; insert the new parameter-list - (goto-char begin) - (ada-insert-paramlist paramlist)) - - ;; restore syntax-table - (set-syntax-table previous-syntax-table) - ))) + (paramlist nil)) + (with-syntax-table ada-mode-symbol-syntax-table + + ;; check if really inside parameter list + (or (ada-in-paramlist-p) + (error "Not in parameter list")) + + ;; find start of current parameter-list + (ada-search-ignore-string-comment + (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) + (down-list 1) + (backward-char 1) + (setq begin (point)) + + ;; find end of parameter-list + (forward-sexp 1) + (setq delend (point)) + (delete-char -1) + (insert "\n") + + ;; find end of last parameter-declaration + (forward-comment -1000) + (setq end (point)) + + ;; build a list of all elements of the parameter-list + (setq paramlist (ada-scan-paramlist (1+ begin) end)) + + ;; delete the original parameter-list + (delete-region begin delend) + + ;; insert the new parameter-list + (goto-char begin) + (ada-insert-paramlist paramlist)))) (defun ada-scan-paramlist (begin end) "Scan the parameter list found in between BEGIN and END. @@ -2186,14 +2176,12 @@ Return the calculation that was done, including the reference point and the offset." (interactive) - (let ((previous-syntax-table (syntax-table)) - (orgpoint (point-marker)) + (let ((orgpoint (point-marker)) cur-indent tmp-indent prev-indent) (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table ;; This need to be done here so that the advice is not always ;; activated (this might interact badly with other modes) @@ -2203,14 +2191,14 @@ (save-excursion (setq cur-indent - ;; Not First line in the buffer ? - (if (save-excursion (zerop (forward-line -1))) - (progn - (back-to-indentation) - (ada-get-current-indent)) - - ;; first line in the buffer - (list (point-min) 0)))) + ;; Not First line in the buffer ? + (if (save-excursion (zerop (forward-line -1))) + (progn + (back-to-indentation) + (ada-get-current-indent)) + + ;; first line in the buffer + (list (point-min) 0)))) ;; Evaluate the list to get the column to indent to ;; prev-indent contains the column to indent to @@ -2242,14 +2230,10 @@ (if (< (current-column) (current-indentation)) (back-to-indentation))) - ;; restore syntax-table - (set-syntax-table previous-syntax-table) (if (featurep 'xemacs) - (ad-deactivate 'parse-partial-sexp)) - ) - - cur-indent - )) + (ad-deactivate 'parse-partial-sexp))) + + cur-indent)) (defun ada-get-current-indent () "Return the indentation to use for the current line." @@ -2512,11 +2496,11 @@ (if (looking-at "renames") (let (pos) (save-excursion - (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t))) + (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t))) (if (and pos (= (downcase (char-after (car pos))) ?r)) (goto-char (car pos))) - (set 'var 'ada-indent-renames))) + (setq var 'ada-indent-renames))) (forward-comment -1000) (if (= (char-before) ?\)) @@ -2533,7 +2517,7 @@ (looking-at "\\(function\\|procedure\\)\\>")) (progn (backward-word 1) - (set 'num-back 2) + (setq num-back 2) (looking-at "\\(function\\|procedure\\)\\>"))))) ;; The indentation depends of the value of ada-indent-return @@ -4046,8 +4030,7 @@ (let (found begin end - parse-result - (previous-syntax-table (syntax-table))) + parse-result) ;; FIXME: need to pass BACKWARD to search-func! (unless search-func @@ -4057,67 +4040,65 @@ ;; search until found or end-of-buffer ;; We have to test that we do not look further than limit ;; - (set-syntax-table ada-mode-symbol-syntax-table) - (while (and (not found) - (or (not limit) - (or (and backward (<= limit (point))) - (>= limit (point)))) - (funcall search-func search-re limit 1)) - (setq begin (match-beginning 0)) - (setq end (match-end 0)) - - (setq parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point))) - - (cond - ;; - ;; If inside a string, skip it (and the following comments) - ;; - ((ada-in-string-p parse-result) - (if (featurep 'xemacs) - (search-backward "\"" nil t) - (goto-char (nth 8 parse-result))) - (unless backward (forward-sexp 1))) - ;; - ;; If inside a comment, skip it (and the following comments) - ;; There is a special code for comments at the end of the file - ;; - ((ada-in-comment-p parse-result) - (if (featurep 'xemacs) - (progn - (forward-line 1) - (beginning-of-line) - (forward-comment -1)) - (goto-char (nth 8 parse-result))) - (unless backward - ;; at the end of the file, it is not possible to skip a comment - ;; so we just go at the end of the line - (if (forward-comment 1) - (progn - (forward-comment 1000) - (beginning-of-line)) - (end-of-line)))) - ;; - ;; directly in front of a comment => skip it, if searching forward - ;; - ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) - (unless backward (progn (forward-char -1) (forward-comment 1000)))) - - ;; - ;; found a parameter-list but should ignore it => skip it - ;; - ((and (not paramlists) (ada-in-paramlist-p)) - (if backward - (search-backward "(" nil t) - (search-forward ")" nil t))) - ;; - ;; found what we were looking for - ;; - (t - (setq found t)))) ; end of loop - - (set-syntax-table previous-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table + (while (and (not found) + (or (not limit) + (or (and backward (<= limit (point))) + (>= limit (point)))) + (funcall search-func search-re limit 1)) + (setq begin (match-beginning 0)) + (setq end (match-end 0)) + + (setq parse-result (parse-partial-sexp + (save-excursion (beginning-of-line) (point)) + (point))) + + (cond + ;; + ;; If inside a string, skip it (and the following comments) + ;; + ((ada-in-string-p parse-result) + (if (featurep 'xemacs) + (search-backward "\"" nil t) + (goto-char (nth 8 parse-result))) + (unless backward (forward-sexp 1))) + ;; + ;; If inside a comment, skip it (and the following comments) + ;; There is a special code for comments at the end of the file + ;; + ((ada-in-comment-p parse-result) + (if (featurep 'xemacs) + (progn + (forward-line 1) + (beginning-of-line) + (forward-comment -1)) + (goto-char (nth 8 parse-result))) + (unless backward + ;; at the end of the file, it is not possible to skip a comment + ;; so we just go at the end of the line + (if (forward-comment 1) + (progn + (forward-comment 1000) + (beginning-of-line)) + (end-of-line)))) + ;; + ;; directly in front of a comment => skip it, if searching forward + ;; + ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) + (unless backward (progn (forward-char -1) (forward-comment 1000)))) + + ;; + ;; found a parameter-list but should ignore it => skip it + ;; + ((and (not paramlists) (ada-in-paramlist-p)) + (if backward + (search-backward "(" nil t) + (search-forward ")" nil t))) + ;; + ;; found what we were looking for + ;; + (t + (setq found t))))) ; end of loop (if found (cons begin end) @@ -4398,122 +4379,109 @@ (defun ada-move-to-start () "Move point to the matching start of the current Ada structure." (interactive) - (let ((pos (point)) - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (save-excursion - ;; - ;; do nothing if in string or comment or not on 'end ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (error "Not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\<begin\\>") - (ada-goto-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos)) - - ;; restore syntax-table - (set-syntax-table previous-syntax-table)))) + (let ((pos (point))) + (with-syntax-table ada-mode-symbol-syntax-table + + (save-excursion + ;; + ;; do nothing if in string or comment or not on 'end ...;' + ;; or if an error occurs during processing + ;; + (or + (ada-in-string-or-comment-p) + (and (progn + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (error "Not on end ...;"))) + (ada-goto-matching-start 1) + (setq pos (point)) + + ;; + ;; on 'begin' => go on, according to user option + ;; + ada-move-to-declaration + (looking-at "\\<begin\\>") + (ada-goto-decl-start) + (setq pos (point)))) + + ) ; end of save-excursion + + ;; now really move to the found position + (goto-char pos)))) (defun ada-move-to-end () "Move point to the end of the block around point. Moves to 'begin' if in a declarative part." (interactive) (let ((pos (point)) - decl-start - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (save-excursion - - (cond - ;; Go to the beginning of the current word, and check if we are - ;; directly on 'begin' - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1) - ) - - ;; on first line of subprogram body - ;; Do nothing for specs or generic instantion, since these are - ;; handled as the general case (find the enclosing block) - ;; We also need to make sure that we ignore nested subprograms - ((save-excursion - (and (skip-syntax-backward "w") - (looking-at "\\<function\\>\\|\\<procedure\\>" ) - (ada-search-ignore-string-comment "is\\|;") - (not (= (char-before) ?\;)) - )) - (skip-syntax-backward "w") - (ada-goto-matching-end 0 t)) - - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<task\\>" ) - (forward-word 1) - (ada-goto-next-non-ws) - (looking-at "\\<body\\>"))) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<accept\\>" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (setq decl-start (and (ada-goto-decl-start t) (point))) - (and decl-start (looking-at "\\<package\\>"))) - (ada-goto-matching-end 1)) - - ;; On a "declare" keyword - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\<declare\\>")) - (ada-goto-matching-end 0 t)) - - ;; inside a 'begin' ... 'end' block - (decl-start - (goto-char decl-start) - (ada-goto-matching-end 0 t)) - - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - ) - - ;; now really move to the position found - (goto-char pos)) - - ;; restore syntax-table - (set-syntax-table previous-syntax-table)))) + decl-start) + (with-syntax-table ada-mode-symbol-syntax-table + + (save-excursion + + (cond + ;; Go to the beginning of the current word, and check if we are + ;; directly on 'begin' + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\<begin\\>")) + (ada-goto-matching-end 1)) + + ;; on first line of subprogram body + ;; Do nothing for specs or generic instantion, since these are + ;; handled as the general case (find the enclosing block) + ;; We also need to make sure that we ignore nested subprograms + ((save-excursion + (and (skip-syntax-backward "w") + (looking-at "\\<function\\>\\|\\<procedure\\>" ) + (ada-search-ignore-string-comment "is\\|;") + (not (= (char-before) ?\;)) + )) + (skip-syntax-backward "w") + (ada-goto-matching-end 0 t)) + + ;; on first line of task declaration + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<task\\>" ) + (forward-word 1) + (ada-goto-next-non-ws) + (looking-at "\\<body\\>"))) + (ada-search-ignore-string-comment "begin" nil nil nil + 'word-search-forward)) + ;; accept block start + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<accept\\>" ))) + (ada-goto-matching-end 0)) + ;; package start + ((save-excursion + (setq decl-start (and (ada-goto-decl-start t) (point))) + (and decl-start (looking-at "\\<package\\>"))) + (ada-goto-matching-end 1)) + + ;; On a "declare" keyword + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\<declare\\>")) + (ada-goto-matching-end 0 t)) + + ;; inside a 'begin' ... 'end' block + (decl-start + (goto-char decl-start) + (ada-goto-matching-end 0 t)) + + ;; (hopefully ;-) everything else + (t + (ada-goto-matching-end 1))) + (setq pos (point)) + ) + + ;; now really move to the position found + (goto-char pos)))) (defun ada-next-procedure () "Move point to next procedure." @@ -4818,7 +4786,7 @@ (if (featurep 'xemacs) (progn (define-key ada-mode-map [menu-bar] ada-mode-menu) - (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) + (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) ;; ------------------------------------------------------- @@ -5040,7 +5008,7 @@ (ada-find-src-file-in-dir (file-name-nondirectory (concat name (car suffixes)))))) (if other - (set 'is-spec other))) + (setq is-spec other))) ;; Else search in the current directory (if (file-exists-p (concat name (car suffixes)))
--- a/lisp/progmodes/antlr-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/antlr-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -951,7 +951,7 @@ (3 antlr-keyword-face) (4 (if (member (match-string 4) '("Lexer" "Parser" "TreeParser")) antlr-keyword-face - type-face))) + font-lock-type-face))) (,(lambda (limit) (antlr-re-search-forward "\\<\\(header\\|options\\|tokens\\|exception\\|catch\\|returns\\)\\>"
--- a/lisp/progmodes/autoconf.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/autoconf.el Wed Sep 22 15:46:51 2010 +0900 @@ -43,9 +43,6 @@ (defvar autoconf-mode-hook nil "Hook run by `autoconf-mode'.") -(defconst autoconf-font-lock-syntactic-keywords - '(("\\<dnl\\>" 0 '(11)))) - (defconst autoconf-definition-regexp "AC_\\(SUBST\\|DEFINE\\(_UNQUOTED\\)?\\)(\\[*\\(\\sw+\\)\\]*") @@ -94,8 +91,8 @@ "^[ \t]*A[CM]_\\(\\sw\\|\\s_\\)+") (set (make-local-variable 'comment-start) "dnl ") (set (make-local-variable 'comment-start-skip) "\\(?:\\<dnl\\|#\\) +") - (set (make-local-variable 'font-lock-syntactic-keywords) - autoconf-font-lock-syntactic-keywords) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules ("\\<dnl\\>" (0 "<")))) (set (make-local-variable 'font-lock-defaults) `(autoconf-font-lock-keywords nil nil (("_" . "w")))) (set (make-local-variable 'imenu-generic-expression)
--- a/lisp/progmodes/cc-engine.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/cc-engine.el Wed Sep 22 15:46:51 2010 +0900 @@ -5449,49 +5449,47 @@ (forward-char) (unless (looking-at c-<-op-cont-regexp) - (while (and + (while (and (progn - (c-forward-syntactic-ws) - (let ((orig-record-found-types c-record-found-types)) - (when (or (and c-record-type-identifiers all-types) - (c-major-mode-is 'java-mode)) - ;; All encountered identifiers are types, so set the - ;; promote flag and parse the type. - (progn - (c-forward-syntactic-ws) - (if (looking-at "\\?") - (forward-char) - (when (looking-at c-identifier-start) - (let ((c-promote-possible-types t) - (c-record-found-types t)) - (c-forward-type)))) - - (c-forward-syntactic-ws) - - (when (or (looking-at "extends") - (looking-at "super")) - (forward-word) - (c-forward-syntactic-ws) - (let ((c-promote-possible-types t) - (c-record-found-types t)) - (c-forward-type) - (c-forward-syntactic-ws)))))) - - (setq pos (point)) - - (or - ;; Note: These regexps exploit the match order in \| so - ;; that "<>" is matched by "<" rather than "[^>:-]>". - (c-syntactic-re-search-forward - ;; Stop on ',', '|', '&', '+' and '-' to catch - ;; common binary operators that could be between - ;; two comparison expressions "a<b" and "c>d". - "[<;{},|+&-]\\|[>)]" - nil t t) - t)) - - (cond - ((eq (char-before) ?>) + (c-forward-syntactic-ws) + (let ((orig-record-found-types c-record-found-types)) + (when (or (and c-record-type-identifiers all-types) + (c-major-mode-is 'java-mode)) + ;; All encountered identifiers are types, so set the + ;; promote flag and parse the type. + (progn + (c-forward-syntactic-ws) + (if (looking-at "\\?") + (forward-char) + (when (looking-at c-identifier-start) + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-type)))) + + (c-forward-syntactic-ws) + + (when (or (looking-at "extends") + (looking-at "super")) + (forward-word) + (c-forward-syntactic-ws) + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-type) + (c-forward-syntactic-ws)))))) + + (setq pos (point)) + + ;; Note: These regexps exploit the match order in \| so + ;; that "<>" is matched by "<" rather than "[^>:-]>". + (c-syntactic-re-search-forward + ;; Stop on ',', '|', '&', '+' and '-' to catch + ;; common binary operators that could be between + ;; two comparison expressions "a<b" and "c>d". + "[<;{},|+&-]\\|[>)]" + nil t t)) + + (cond + ((eq (char-before) ?>) ;; Either an operator starting with '>' or the end of ;; the angle bracket arglist. @@ -5532,14 +5530,14 @@ (when (or (setq keyword-match (looking-at c-opt-<>-sexp-key)) (not (looking-at c-keywords-regexp))) - (setq id-start (point)))) - - (setq subres - (let ((c-promote-possible-types t) - (c-record-found-types t)) - (c-forward-<>-arglist-recur - (and keyword-match - (c-keyword-member + (setq id-start (point)))) + + (setq subres + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-<>-arglist-recur + (and keyword-match + (c-keyword-member (c-keyword-sym (match-string 1)) 'c-<>-type-kwds))))) ))) @@ -5560,16 +5558,16 @@ (c-forward-syntactic-ws) (looking-at c-opt-identifier-concat-key))) (c-record-ref-id (cons id-start id-end)) - (c-record-type-id (cons id-start id-end)))))) - t) - - ((and (not c-restricted-<>-arglists) - (or (and (eq (char-before) ?&) - (not (eq (char-after) ?&))) - (eq (char-before) ?,))) - ;; Just another argument. Record the position. The - ;; type check stuff that made us stop at it is at - ;; the top of the loop. + (c-record-type-id (cons id-start id-end)))))) + t) + + ((and (not c-restricted-<>-arglists) + (or (and (eq (char-before) ?&) + (not (eq (char-after) ?&))) + (eq (char-before) ?,))) + ;; Just another argument. Record the position. The + ;; type check stuff that made us stop at it is at + ;; the top of the loop. (setq arg-start-pos (cons (point) arg-start-pos))) (t
--- a/lisp/progmodes/cfengine.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/cfengine.el Wed Sep 22 15:46:51 2010 +0900 @@ -83,12 +83,6 @@ ;; File, acl &c in group: { token ... } ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face))) -(defconst cfengine-font-lock-syntactic-keywords - ;; In the main syntax-table, backslash is marked as a punctuation, because - ;; of its use in DOS-style directory separators. Here we try to recognize - ;; the cases where backslash is used as an escape inside strings. - '(("\\(\\(?:\\\\\\)+\\)\"" 1 "\\"))) - (defvar cfengine-imenu-expression `((nil ,(concat "^[ \t]*" (eval-when-compile (regexp-opt cfengine-actions t)) @@ -237,13 +231,15 @@ (set (make-local-variable 'fill-paragraph-function) #'cfengine-fill-paragraph) (define-abbrev-table 'cfengine-mode-abbrev-table cfengine-mode-abbrevs) - ;; Fixme: Use `font-lock-syntactic-keywords' to set the args of - ;; functions in evaluated classes to string syntax, and then obey - ;; syntax properties. (setq font-lock-defaults - '(cfengine-font-lock-keywords nil nil nil beginning-of-line - (font-lock-syntactic-keywords - . cfengine-font-lock-syntactic-keywords))) + '(cfengine-font-lock-keywords nil nil nil beginning-of-line)) + ;; Fixme: set the args of functions in evaluated classes to string + ;; syntax, and then obey syntax properties. + (set (make-local-variable 'syntax-propertize-function) + ;; In the main syntax-table, \ is marked as a punctuation, because + ;; of its use in DOS-style directory separators. Here we try to + ;; recognize the cases where \ is used as an escape inside strings. + (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\")))) (setq imenu-generic-expression cfengine-imenu-expression) (set (make-local-variable 'beginning-of-defun-function) #'cfengine-beginning-of-defun)
--- a/lisp/progmodes/compile.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/compile.el Wed Sep 22 15:46:51 2010 +0900 @@ -164,7 +164,7 @@ (defvar compilation-num-errors-found) -(defconst compilation-error-regexp-alist-alist +(defvar compilation-error-regexp-alist-alist '((absoft "^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) @@ -263,9 +263,11 @@ ;; The core of the regexp is the one with *?. It says that a file name ;; can be composed of any non-newline char, but it also rules out some ;; valid but unlikely cases, such as a trailing space or a space - ;; followed by a -. + ;; followed by a -, or a colon followed by a space. + + ;; The "in \\|from " exception was added to handle messages from Ruby. "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\|[ \t]+\\(?:in \\|from \\)\\)?\ -\\([0-9]*[^0-9\n]\\(?:[^\n ]\\| [^-/\n]\\)*?\\): ?\ +\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\): ?\ \\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\ \\(?:-\\([0-9]+\\)?\\(?:\\.\\([0-9]+\\)\\)?\\)?:\ \\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ @@ -766,12 +768,27 @@ skip anything less than warning or 0 -- don't skip any messages. Note that all messages not positively identified as warning or info, are considered errors." - :type '(choice (const :tag "Warnings and info" 2) - (const :tag "Info" 1) - (const :tag "None" 0)) + :type '(choice (const :tag "Skip warnings and info" 2) + (const :tag "Skip info" 1) + (const :tag "No skip" 0)) :group 'compilation :version "22.1") +(defun compilation-set-skip-threshold (level) + "Switch the `compilation-skip-threshold' level." + (interactive + (list + (mod (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (1+ compilation-skip-threshold)) + 3))) + (setq compilation-skip-threshold level) + (message "Skipping %s" + (case compilation-skip-threshold + (0 "Nothing") + (1 "Info messages") + (2 "Warnings and info")))) + (defcustom compilation-skip-visited nil "Compilation motion commands skip visited messages if this is t. Visited messages are ones for which the file, line and column have been jumped @@ -1212,7 +1229,7 @@ (let* ((name-of-mode (if (eq mode t) "compilation" - (replace-regexp-in-string "-mode$" "" (symbol-name mode)))) + (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) (thisdir default-directory) outwin outbuf) (with-current-buffer @@ -2377,7 +2394,7 @@ (defun compilation-forget-errors () ;; In case we hit the same file/line specs, we want to recompute a new ;; marker for them, so flush our cache. - (setq compilation-locs (make-hash-table :test 'equal :weakness 'value)) + (clrhash compilation-locs) (setq compilation-gcpro nil) ;; FIXME: the old code reset the directory-stack, so maybe we should ;; put a `directory change' marker of some sort, but where? -stef
--- a/lisp/progmodes/cperl-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/cperl-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -1840,7 +1840,13 @@ (make-local-variable 'cperl-syntax-state) (setq cperl-syntax-state nil) ; reset syntaxification cache (if cperl-use-syntax-table-text-property - (progn + (if (boundp 'syntax-propertize-function) + (progn + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-done-to) nil) + (set (make-local-variable 'syntax-propertize-function) + (lambda (start end) + (goto-char start) (cperl-fontify-syntaxically end)))) (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! (set 'parse-sexp-lookup-properties t)
--- a/lisp/progmodes/fortran.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/fortran.el Wed Sep 22 15:46:51 2010 +0900 @@ -488,13 +488,22 @@ ;; (We can do so for F90-style). Therefore an unmatched quote in a ;; standard comment will throw fontification off on the wrong track. ;; So we do syntactic fontification with regexps. -(defun fortran-font-lock-syntactic-keywords () - "Return a value for `font-lock-syntactic-keywords' in Fortran mode. -This varies according to the value of `fortran-line-length'. +(defun fortran-make-syntax-propertize-function (line-length) + "Return a value for `syntax-propertize-function' in Fortran mode. +This varies according to the value of LINE-LENGTH. This is used to fontify fixed-format Fortran comments." - `(("^[cd\\*]" 0 (11)) - (,(format "^[^cd\\*\t\n].\\{%d\\}\\([^\n]+\\)" (1- fortran-line-length)) - 1 (11)))) + ;; This results in a non-byte-compiled function. We could pass it through + ;; `byte-compile', but simple benchmarks indicate that it's probably not + ;; worth the trouble (about ½% of slow down). + (eval ;I hate `eval', but it's hard to avoid it here. + `(syntax-propertize-rules + ("^[cd\\*]" (0 "<")) + ;; We mark all chars after line-length as "comment-start", rather than + ;; just the first one. This is so that a closing ' that's past the + ;; line-length will indeed be ignored (and will result in a string that + ;; leaks into subsequent lines). + ((format "^[^cd\\*\t\n].\\{%d\\}\\(.+\\)" (1- line-length)) + (1 "<"))))) (defvar fortran-font-lock-keywords fortran-font-lock-keywords-1 "Default expressions to highlight in Fortran mode.") @@ -887,9 +896,9 @@ fortran-font-lock-keywords-3 fortran-font-lock-keywords-4) nil t ((?/ . "$/") ("_$" . "w")) - fortran-beginning-of-subprogram - (font-lock-syntactic-keywords - . fortran-font-lock-syntactic-keywords))) + fortran-beginning-of-subprogram)) + (set (make-local-variable 'syntax-propertize-function) + (fortran-make-syntax-propertize-function fortran-line-length)) (set (make-local-variable 'imenu-case-fold-search) t) (set (make-local-variable 'imenu-generic-expression) fortran-imenu-generic-expression) @@ -909,25 +918,30 @@ "Set the length of fixed-form Fortran lines to NCHARS. This normally only affects the current buffer, which must be in Fortran mode. If the optional argument GLOBAL is non-nil, it -affects all Fortran buffers, and also the default." - (interactive "p") - (let (new) - (mapc (lambda (buff) - (with-current-buffer buff - (when (eq major-mode 'fortran-mode) - (setq fortran-line-length nchars - fill-column fortran-line-length - new (fortran-font-lock-syntactic-keywords)) - ;; Refontify only if necessary. - (unless (equal new font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords - (fortran-font-lock-syntactic-keywords)) - (if font-lock-mode (font-lock-mode 1)))))) +affects all Fortran buffers, and also the default. +If a numeric prefix argument is specified, it will be used as NCHARS, +otherwise is a non-numeric prefix arg is specified, the length will be +provided via the minibuffer, and otherwise the current column is used." + (interactive + (list (cond + ((numberp current-prefix-arg) current-prefix-arg) + (current-prefix-arg + (read-number "Line length: " (default-value 'fortran-line-length))) + (t (current-column))))) + (dolist (buff (if global + (buffer-list) + (list (current-buffer)))) + (with-current-buffer buff + (when (derived-mode-p 'fortran-mode) + (unless (eq fortran-line-length nchars) + (setq fortran-line-length nchars + fill-column fortran-line-length + syntax-propertize-function + (fortran-make-syntax-propertize-function nchars)) + (syntax-ppss-flush-cache (point-min)) + (if font-lock-mode (font-lock-mode 1)))))) (if global - (buffer-list) - (list (current-buffer)))) - (if global - (setq-default fortran-line-length nchars)))) + (setq-default fortran-line-length nchars))) (defun fortran-hack-local-variables () "Fortran mode adds this to `hack-local-variables-hook'."
--- a/lisp/progmodes/gud.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/gud.el Wed Sep 22 15:46:51 2010 +0900 @@ -3123,10 +3123,12 @@ ("\\$\\(\\w+\\)" (1 font-lock-variable-name-face)) ("^\\s-*\\(\\w\\(\\w\\|\\s_\\)*\\)" (1 font-lock-keyword-face)))) -(defvar gdb-script-font-lock-syntactic-keywords - '(("^document\\s-.*\\(\n\\)" (1 "< b")) - ("^end\\>" - (0 (unless (eq (match-beginning 0) (point-min)) +(defconst gdb-script-syntax-propertize-function + (syntax-propertize-rules + ("^document\\s-.*\\(\n\\)" (1 "< b")) + ("^end\\(\\>\\)" + (1 (ignore + (unless (eq (match-beginning 0) (point-min)) ;; We change the \n in front, which is more difficult, but results ;; in better highlighting. If the doc is empty, the single \n is ;; both the beginning and the end of the docstring, which can't be @@ -3138,10 +3140,9 @@ 'syntax-table (eval-when-compile (string-to-syntax "> b"))) ;; Make sure that rehighlighting the previous line won't erase our - ;; syntax-table property. + ;; syntax-table property and that modifying `end' will. (put-text-property (1- (match-beginning 0)) (match-end 0) - 'font-lock-multiline t) - nil))))) + 'syntax-multiline t))))))) (defun gdb-script-font-lock-syntactic-face (state) (cond @@ -3239,10 +3240,13 @@ #'gdb-script-end-of-defun) (set (make-local-variable 'font-lock-defaults) '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil - (font-lock-syntactic-keywords - . gdb-script-font-lock-syntactic-keywords) (font-lock-syntactic-face-function - . gdb-script-font-lock-syntactic-face)))) + . gdb-script-font-lock-syntactic-face))) + ;; Recognize docstrings. + (set (make-local-variable 'syntax-propertize-function) + gdb-script-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local)) ;;; tooltips for GUD
--- a/lisp/progmodes/js.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/js.el Wed Sep 22 15:46:51 2010 +0900 @@ -45,16 +45,16 @@ ;;; Code: -(eval-and-compile - (require 'cc-mode) - (require 'font-lock) - (require 'newcomment) - (require 'imenu) - (require 'etags) - (require 'thingatpt) - (require 'easymenu) - (require 'moz nil t) - (require 'json nil t)) + +(require 'cc-mode) +(require 'font-lock) +(require 'newcomment) +(require 'imenu) +(require 'etags) +(require 'thingatpt) +(require 'easymenu) +(require 'moz nil t) +(require 'json nil t) (eval-when-compile (require 'cl) @@ -725,20 +725,19 @@ If invoked while inside a macro, it treats the contents of the macro as normal text." + (unless count (setq count 1)) (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js--re-search-forward-inner regexp bound 1)) - ((< count 0) - '(js--re-search-backward-inner regexp bound (- count))) - ((> count 0) - '(js--re-search-forward-inner regexp bound count))))) + (search-fun + (cond ((< count 0) (setq count (- count)) + #'js--re-search-backward-inner) + ((> count 0) #'js--re-search-forward-inner) + (t #'ignore)))) (condition-case err - (eval search-expr) + (funcall search-fun regexp bound count) (search-failed (goto-char saved-point) (unless noerror - (error (error-message-string err))))))) + (signal (car err) (cdr err))))))) (defun js--re-search-backward-inner (regexp &optional bound count) @@ -782,20 +781,7 @@ removed. If invoked while inside a macro, treat the macro as normal text." - (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js--re-search-backward-inner regexp bound 1)) - ((< count 0) - '(js--re-search-forward-inner regexp bound (- count))) - ((> count 0) - '(js--re-search-backward-inner regexp bound count))))) - (condition-case err - (eval search-expr) - (search-failed - (goto-char saved-point) - (unless noerror - (error (error-message-string err))))))) + (js--re-search-forward regexp bound noerror (if count (- count) -1))) (defun js--forward-expression () "Move forward over a whole JavaScript expression. @@ -1674,18 +1660,19 @@ ;; XXX: Javascript can continue a regexp literal across lines so long ;; as the newline is escaped with \. Account for that in the regexp ;; below. -(defconst js--regexp-literal +(eval-and-compile + (defconst js--regexp-literal "[=(,:]\\(?:\\s-\\|\n\\)*\\(/\\)\\(?:\\\\/\\|[^/*]\\)\\(?:\\\\/\\|[^/]\\)*\\(/\\)" "Regexp matching a JavaScript regular expression literal. Match groups 1 and 2 are the characters forming the beginning and -end of the literal.") - -;; we want to match regular expressions only at the beginning of -;; expressions -(defconst js-font-lock-syntactic-keywords - `((,js--regexp-literal (1 "|") (2 "|"))) - "Syntactic font lock keywords matching regexps in JavaScript. -See `font-lock-keywords'.") +end of the literal.")) + + +(defconst js-syntax-propertize-function + (syntax-propertize-rules + ;; We want to match regular expressions only at the beginning of + ;; expressions. + (js--regexp-literal (1 "\"") (2 "\"")))) ;;; Indentation @@ -3317,10 +3304,9 @@ (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil) (set (make-local-variable 'font-lock-defaults) - (list js--font-lock-keywords - nil nil nil nil - '(font-lock-syntactic-keywords - . js-font-lock-syntactic-keywords))) + (list js--font-lock-keywords)) + (set (make-local-variable 'syntax-propertize-function) + js-syntax-propertize-function) (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'parse-sexp-lookup-properties) t)
--- a/lisp/progmodes/make-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/make-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -505,15 +505,16 @@ cpp-font-lock-keywords)) -(defconst makefile-font-lock-syntactic-keywords - ;; From sh-script.el. - ;; A `#' begins a comment in sh when it is unquoted and at the beginning - ;; of a word. In the shell, words are separated by metacharacters. - ;; The list of special chars is taken from the single-unix spec of the - ;; shell command language (under `quoting') but with `$' removed. - '(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 "_") - ;; Change the syntax of a quoted newline so that it does not end a comment. - ("\\\\\n" 0 "."))) +(defconst makefile-syntax-propertize-function + (syntax-propertize-rules + ;; From sh-script.el. + ;; A `#' begins a comment in sh when it is unquoted and at the beginning + ;; of a word. In the shell, words are separated by metacharacters. + ;; The list of special chars is taken from the single-unix spec of the + ;; shell command language (under `quoting') but with `$' removed. + ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_")) + ;; Change the syntax of a quoted newline so that it does not end a comment. + ("\\\\\n" (0 ".")))) (defvar makefile-imenu-generic-expression `(("Dependencies" makefile-previous-dependency 1) @@ -872,9 +873,9 @@ '(makefile-font-lock-keywords nil nil ((?$ . ".")) - backward-paragraph - (font-lock-syntactic-keywords - . makefile-font-lock-syntactic-keywords))) + backward-paragraph)) + (set (make-local-variable 'syntax-propertize-function) + makefile-syntax-propertize-function) ;; Add-log. (set (make-local-variable 'add-log-current-defun-function) @@ -943,15 +944,9 @@ (define-derived-mode makefile-imake-mode makefile-mode "Imakefile" "An adapted `makefile-mode' that knows about imake." :syntax-table makefile-imake-mode-syntax-table - (let ((base `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults))) - new) - ;; Remove `font-lock-syntactic-keywords' entry from font-lock-defaults. - (mapc (lambda (elt) - (unless (and (consp elt) - (eq (car elt) 'font-lock-syntactic-keywords)) - (setq new (cons elt new)))) - base) - (setq font-lock-defaults (nreverse new)))) + (set (make-local-variable 'syntax-propertize-function) nil) + (setq font-lock-defaults + `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults))))
--- a/lisp/progmodes/mixal-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/mixal-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -89,7 +89,7 @@ (defvar mixal-mode-syntax-table (let ((st (make-syntax-table))) ;; We need to do a bit more to make fontlocking for comments work. - ;; See mixal-font-lock-syntactic-keywords. + ;; See use of syntax-propertize-function. ;; (modify-syntax-entry ?* "<" st) (modify-syntax-entry ?\n ">" st) st) @@ -1028,13 +1028,14 @@ ;;; Font-locking: -(defvar mixal-font-lock-syntactic-keywords - ;; Normal comments start with a * in column 0 and end at end of line. - '(("^\\*" (0 '(11))) ;(string-to-syntax "<") == '(11) - ;; Every line can end with a comment which is placed after the operand. - ;; I assume here that mnemonics without operands can not have a comment. - ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]" - (1 '(11))))) +(defconst mixal-syntax-propertize-function + (syntax-propertize-rules + ;; Normal comments start with a * in column 0 and end at end of line. + ("^\\*" (0 "<")) + ;; Every line can end with a comment which is placed after the operand. + ;; I assume here that mnemonics without operands can not have a comment. + ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]" + (1 "<")))) (defvar mixal-font-lock-keywords `(("^\\([A-Z0-9a-z]+\\)" @@ -1110,9 +1111,9 @@ (set (make-local-variable 'comment-start) "*") (set (make-local-variable 'comment-start-skip) "^\\*[ \t]*") (set (make-local-variable 'font-lock-defaults) - `(mixal-font-lock-keywords nil nil nil nil - (font-lock-syntactic-keywords . ,mixal-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + `(mixal-font-lock-keywords)) + (set (make-local-variable 'syntax-propertize-function) + mixal-syntax-propertize-function) ;; might add an indent function in the future ;; (set (make-local-variable 'indent-line-function) 'mixal-indent-line) (set (make-local-variable 'compile-command) (concat "mixasm "
--- a/lisp/progmodes/octave-mod.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/octave-mod.el Wed Sep 22 15:46:51 2010 +0900 @@ -179,38 +179,28 @@ '(3 font-lock-function-name-face nil t))) "Additional Octave expressions to highlight.") -(defvar octave-font-lock-syntactic-keywords +(defun octave-syntax-propertize-function (start end) + (goto-char start) + (octave-syntax-propertize-sqs end) + (funcall (syntax-propertize-rules ;; Try to distinguish the string-quotes from the transpose-quotes. - '(("[[({,; ]\\('\\)" (1 "\"'")) - (octave-font-lock-close-quotes))) + ("[[({,; ]\\('\\)" + (1 (prog1 "\"'" (octave-syntax-propertize-sqs end))))) + (point) end)) -(defun octave-font-lock-close-quotes (limit) - "Fix the syntax-table of the closing quotes of single-quote strings." - ;; Freely inspired from perl-font-lock-special-syntactic-constructs. - (let ((state (syntax-ppss))) - (while (< (point) limit) - (cond - ((eq (nth 3 state) ?\') +(defun octave-syntax-propertize-sqs (end) + "Propertize the content/end of single-quote strings." + (when (eq (nth 3 (syntax-ppss)) ?\') ;; A '..' string. - (save-excursion - (when (re-search-forward "\\(?:\\=\\|[^']\\)\\(?:''\\)*\\('\\)[^']" - nil t) - (goto-char (1- (point))) - ;; Remove any syntax-table property we may have applied to - ;; some of the (doubled) single quotes within the string. - ;; Since these are the only chars on which we place properties, - ;; we take a shortcut and just remove all properties. - (remove-text-properties (1+ (nth 8 state)) (match-beginning 1) - '(syntax-table nil)) + (when (re-search-forward + "\\(?:\\=\\|[^']\\)\\(?:''\\)*\\('\\)\\($\\|[^']\\)" end 'move) + (goto-char (match-beginning 2)) (when (eq (char-before (match-beginning 1)) ?\\) ;; Backslash cannot escape a single quote. (put-text-property (1- (match-beginning 1)) (match-beginning 1) 'syntax-table (string-to-syntax "."))) (put-text-property (match-beginning 1) (match-end 1) - 'syntax-table (string-to-syntax "\"'")))))) - - (setq state (parse-partial-sexp (point) limit nil nil state - 'syntax-table))))) + 'syntax-table (string-to-syntax "\"'"))))) (defcustom inferior-octave-buffer "*Inferior Octave*" "Name of buffer for running an inferior Octave process." @@ -544,6 +534,8 @@ 0) ((:before . "case") octave-block-offset))) +(defvar electric-indent-chars) + ;;;###autoload (define-derived-mode octave-mode prog-mode "Octave" "Major mode for editing Octave code. @@ -682,9 +674,10 @@ (set (make-local-variable 'normal-auto-fill-function) 'octave-auto-fill) (set (make-local-variable 'font-lock-defaults) - '(octave-font-lock-keywords nil nil nil nil - (font-lock-syntactic-keywords . octave-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + '(octave-font-lock-keywords)) + + (set (make-local-variable 'syntax-propertize-function) + #'octave-syntax-propertize-function) (set (make-local-variable 'imenu-generic-expression) octave-mode-imenu-generic-expression)
--- a/lisp/progmodes/pascal.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/pascal.el Wed Sep 22 15:46:51 2010 +0900 @@ -223,7 +223,7 @@ "*List of contexts where auto lineup of :'s or ='s should be done. Elements can be of type: 'paramlist', 'declaration' or 'case', which will do auto lineup in parameterlist, declarations or case-statements -respectively. The word 'all' will do all lineups. '(case paramlist) for +respectively. The word 'all' will do all lineups. '(case paramlist) for instance will do lineup in case-statements and parameterlist, while '(all) will do all lineups." :type '(set :extra-offset 8 @@ -311,7 +311,7 @@ ;;;###autoload -(defun pascal-mode () +(define-derived-mode pascal-mode prog-mode "Pascal" "Major mode for editing Pascal code. \\<pascal-mode-map> TAB indents for Pascal code. Delete converts tabs to spaces as it moves back. @@ -334,60 +334,47 @@ Variables controlling indentation/edit style: - pascal-indent-level (default 3) + `pascal-indent-level' (default 3) Indentation of Pascal statements with respect to containing block. - pascal-case-indent (default 2) + `pascal-case-indent' (default 2) Indentation for case statements. - pascal-auto-newline (default nil) + `pascal-auto-newline' (default nil) Non-nil means automatically newline after semicolons and the punctuation mark after an end. - pascal-indent-nested-functions (default t) + `pascal-indent-nested-functions' (default t) Non-nil means nested functions are indented. - pascal-tab-always-indent (default t) + `pascal-tab-always-indent' (default t) Non-nil means TAB in Pascal mode should always reindent the current line, regardless of where in the line point is when the TAB command is used. - pascal-auto-endcomments (default t) + `pascal-auto-endcomments' (default 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. - pascal-auto-lineup (default t) + `pascal-auto-lineup' (default t) List of contexts where auto lineup of :'s or ='s should be done. -See also the user variables pascal-type-keywords, pascal-start-keywords and -pascal-separator-keywords. +See also the user variables `pascal-type-keywords', `pascal-start-keywords' and +`pascal-separator-keywords'. Turning on Pascal mode calls the value of the variable pascal-mode-hook with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map pascal-mode-map) - (setq major-mode 'pascal-mode) - (setq mode-name "Pascal") - (setq local-abbrev-table pascal-mode-abbrev-table) - (set-syntax-table pascal-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'pascal-indent-line) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'pascal-indent-comment) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'blink-matching-paren-dont-ignore-comments) - (setq blink-matching-paren-dont-ignore-comments t) - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - (make-local-variable 'comment-start) - (setq comment-start "{") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *\\|{ *") - (make-local-variable 'comment-end) - (setq comment-end "}") + (set (make-local-variable 'local-abbrev-table) pascal-mode-abbrev-table) + (set (make-local-variable 'indent-line-function) 'pascal-indent-line) + (set (make-local-variable 'comment-indent-function) 'pascal-indent-comment) + (set (make-local-variable 'parse-sexp-ignore-comments) nil) + (set (make-local-variable 'blink-matching-paren-dont-ignore-comments) t) + (set (make-local-variable 'case-fold-search) t) + (set (make-local-variable 'comment-start) "{") + (set (make-local-variable 'comment-start-skip) "(\\*+ *\\|{ *") + (set (make-local-variable 'comment-end) "}") ;; Font lock support - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(pascal-font-lock-keywords nil t)) + (set (make-local-variable 'font-lock-defaults) + '(pascal-font-lock-keywords nil t)) ;; Imenu support - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression pascal-imenu-generic-expression) - (setq imenu-case-fold-search t) - (run-mode-hooks 'pascal-mode-hook)) + (set (make-local-variable 'imenu-generic-expression) + pascal-imenu-generic-expression) + (set (make-local-variable 'imenu-case-fold-search) t) + ;; Pascal-mode's own hide/show support. + (add-to-invisibility-spec '(pascal . t))) @@ -1478,18 +1465,12 @@ (unless pascal-outline-mode (pascal-show-all))) -(defun pascal-outline-change (b e pascal-flag) - (save-excursion - ;; This used to use selective display so the boundaries used by the - ;; callers didn't have to be precise, since it just looked for \n or \^M - ;; and switched them. - (goto-char b) (setq b (line-end-position)) - (goto-char e) (setq e (line-end-position))) +(defun pascal-outline-change (b e hide) (when (> e b) ;; We could try and optimize this in the case where the region is ;; already hidden. But I'm not sure it's worth the trouble. (remove-overlays b e 'invisible 'pascal) - (when (eq pascal-flag ?\^M) + (when hide (let ((ol (make-overlay b e nil t nil))) (overlay-put ol 'invisible 'pascal) (overlay-put ol 'evaporate t))))) @@ -1497,7 +1478,7 @@ (defun pascal-show-all () "Show all of the text in the buffer." (interactive) - (pascal-outline-change (point-min) (point-max) ?\n)) + (pascal-outline-change (point-min) (point-max) nil)) (defun pascal-hide-other-defuns () "Show only the current defun." @@ -1505,42 +1486,45 @@ (save-excursion (let ((beg (progn (if (not (looking-at "\\(function\\|procedure\\)\\>")) (pascal-beg-of-defun)) - (point))) + (line-beginning-position))) (end (progn (pascal-end-of-defun) (backward-sexp 1) - (search-forward "\n\\|\^M" nil t) - (point))) + (line-beginning-position 2))) (opoint (point-min))) + ;; BEG at BOL. + ;; OPOINT at EOL. + ;; END at BOL. (goto-char (point-min)) ;; Hide all functions before current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" beg 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) + (while (re-search-forward "^[ \t]*\\(function\\|procedure\\)\\>" + beg 'move) + (pascal-outline-change opoint (line-end-position 0) t) + (setq opoint (line-end-position)) ;; Functions may be nested (if (> (progn (pascal-end-of-defun) (point)) beg) (goto-char opoint))) (if (> beg opoint) - (pascal-outline-change opoint (1- beg) ?\^M)) + (pascal-outline-change opoint (1- beg) t)) ;; Show current function - (pascal-outline-change beg end ?\n) + (pascal-outline-change (1- beg) end nil) ;; Hide nested functions (forward-char 1) (while (re-search-forward "^\\(function\\|procedure\\)\\>" end 'move) - (setq opoint (point)) + (setq opoint (line-end-position)) (pascal-end-of-defun) - (pascal-outline-change opoint (point) ?\^M)) + (pascal-outline-change opoint (line-end-position) t)) (goto-char end) (setq opoint end) ;; Hide all function after current function (while (re-search-forward "^\\(function\\|procedure\\)\\>" nil 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) + (pascal-outline-change opoint (line-end-position 0) t) + (setq opoint (line-end-position)) (pascal-end-of-defun)) - (pascal-outline-change opoint (point-max) ?\^M) + (pascal-outline-change opoint (point-max) t) ;; Hide main program (if (< (progn (forward-line -1) (point)) end) @@ -1548,7 +1532,7 @@ (goto-char beg) (pascal-end-of-defun) (backward-sexp 1) - (pascal-outline-change (point) (point-max) ?\^M)))))) + (pascal-outline-change (line-end-position) (point-max) t)))))) (defun pascal-outline-next-defun () "Move to next function/procedure, hiding all others."
--- a/lisp/progmodes/perl-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/perl-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -250,59 +250,76 @@ ;; y /.../.../ ;; ;; <file*glob> -(defvar perl-font-lock-syntactic-keywords - ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)") - `(;; Turn POD into b-style comments - ("^\\(=\\)\\sw" (1 "< b")) - ("^=cut[ \t]*\\(\n\\)" (1 "> b")) - ;; Catch ${ so that ${var} doesn't screw up indentation. - ;; This also catches $' to handle 'foo$', although it should really - ;; check that it occurs inside a '..' string. - ("\\(\\$\\)[{']" (1 ". p")) - ;; Handle funny names like $DB'stop. - ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_")) - ;; format statements - ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 '(7))) - ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'. - ;; Be careful not to match "sub { (...) ... }". - ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))" - 1 '(1)) - ;; Regexp and funny quotes. Distinguishing a / that starts a regexp - ;; match from the division operator is ...interesting. - ;; Basically, / is a regexp match if it's preceded by an infix operator - ;; (or some similar separator), or by one of the special keywords - ;; corresponding to builtin functions that can take their first arg - ;; without parentheses. Of course, that presume we're looking at the - ;; *opening* slash. We can afford to mis-match the closing ones - ;; here, because they will be re-treated separately later in - ;; perl-font-lock-special-syntactic-constructs. - (,(concat "\\(?:\\(?:\\(?:^\\|[^$@&%[:word:]]\\)" - (regexp-opt '("split" "if" "unless" "until" "while" "split" - "grep" "map" "not" "or" "and")) - "\\)\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)") - (2 (if (and (match-end 1) - (save-excursion - (goto-char (match-end 1)) - ;; Not 100% correct since we haven't finished setting up - ;; the syntax-table before point, but better than nothing. - (forward-comment (- (point-max))) - (put-text-property (point) (match-end 2) - 'jit-lock-defer-multiline t) - (not (memq (char-before) - '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[))))) - nil ;; A division sign instead of a regexp-match. - '(7)))) - ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)" - ;; Nasty cases: - ;; /foo/m $a->m $#m $m @m %m - ;; \s (appears often in regexps). - ;; -s file - (3 (if (assoc (char-after (match-beginning 3)) - perl-quote-like-pairs) - '(15) '(7)))) - ;; Find and mark the end of funny quotes and format statements. - (perl-font-lock-special-syntactic-constructs) - )) +(defun perl-syntax-propertize-function (start end) + (let ((case-fold-search nil)) + (goto-char start) + (perl-syntax-propertize-special-constructs end) + ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)") + (funcall + (syntax-propertize-rules + ;; Turn POD into b-style comments. Place the cut rule first since it's + ;; more specific. + ("^=cut\\>.*\\(\n\\)" (1 "> b")) + ("^\\(=\\)\\sw" (1 "< b")) + ;; Catch ${ so that ${var} doesn't screw up indentation. + ;; This also catches $' to handle 'foo$', although it should really + ;; check that it occurs inside a '..' string. + ("\\(\\$\\)[{']" (1 ". p")) + ;; Handle funny names like $DB'stop. + ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_")) + ;; format statements + ("^[ \t]*format.*=[ \t]*\\(\n\\)" + (1 (prog1 "\"" (perl-syntax-propertize-special-constructs end)))) + ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'. + ;; Be careful not to match "sub { (...) ... }". + ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))" + (1 ".")) + ;; Regexp and funny quotes. Distinguishing a / that starts a regexp + ;; match from the division operator is ...interesting. + ;; Basically, / is a regexp match if it's preceded by an infix operator + ;; (or some similar separator), or by one of the special keywords + ;; corresponding to builtin functions that can take their first arg + ;; without parentheses. Of course, that presume we're looking at the + ;; *opening* slash. We can afford to mis-match the closing ones + ;; here, because they will be re-treated separately later in + ;; perl-font-lock-special-syntactic-constructs. + ((concat "\\(?:\\(?:^\\|[^$@&%[:word:]]\\)" + (regexp-opt '("split" "if" "unless" "until" "while" "split" + "grep" "map" "not" "or" "and")) + "\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)") + (2 (ignore + (if (and (match-end 1) ; / at BOL. + (save-excursion + (goto-char (match-end 1)) + (forward-comment (- (point-max))) + (put-text-property (point) (match-end 2) + 'syntax-multiline t) + (not (memq (char-before) + '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[))))) + nil ;; A division sign instead of a regexp-match. + (put-text-property (match-beginning 2) (match-end 2) + 'syntax-table (string-to-syntax "\"")) + (perl-syntax-propertize-special-constructs end))))) + ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)" + ;; Nasty cases: + ;; /foo/m $a->m $#m $m @m %m + ;; \s (appears often in regexps). + ;; -s file + ;; sub tr {...} + (3 (ignore + (if (save-excursion (goto-char (match-beginning 0)) + (forward-word -1) + (looking-at-p "sub[ \t\n]")) + ;; This is defining a function. + nil + (put-text-property (match-beginning 3) (match-end 3) + 'syntax-table + (if (assoc (char-after (match-beginning 3)) + perl-quote-like-pairs) + (string-to-syntax "|") + (string-to-syntax "\""))) + (perl-syntax-propertize-special-constructs end)))))) + (point) end))) (defvar perl-empty-syntax-table (let ((st (copy-syntax-table))) @@ -321,95 +338,123 @@ (modify-syntax-entry close ")" st)) st)) -(defun perl-font-lock-special-syntactic-constructs (limit) - ;; We used to do all this in a font-lock-syntactic-face-function, which - ;; did not work correctly because sometimes some parts of the buffer are - ;; treated with font-lock-syntactic-keywords but not with - ;; font-lock-syntactic-face-function (mostly because of - ;; font-lock-syntactically-fontified). That meant that some syntax-table - ;; properties were missing. So now we do the parse-partial-sexp loop - ;; ourselves directly from font-lock-syntactic-keywords, so we're sure - ;; it's done when necessary. +(defun perl-syntax-propertize-special-constructs (limit) + "Propertize special constructs like regexps and formats." (let ((state (syntax-ppss)) char) - (while (< (point) limit) - (cond - ((or (null (setq char (nth 3 state))) - (and (characterp char) (eq (char-syntax (nth 3 state)) ?\"))) - ;; Normal text, or comment, or docstring, or normal string. - nil) - ((eq (nth 3 state) ?\n) - ;; A `format' command. - (save-excursion - (when (and (re-search-forward "^\\s *\\.\\s *$" nil t) - (not (eobp))) - (put-text-property (point) (1+ (point)) 'syntax-table '(7))))) - (t - ;; This is regexp like quote thingy. - (setq char (char-after (nth 8 state))) - (save-excursion - (let ((twoargs (save-excursion - (goto-char (nth 8 state)) - (skip-syntax-backward " ") - (skip-syntax-backward "w") - (member (buffer-substring - (point) (progn (forward-word 1) (point))) - '("tr" "s" "y")))) - (close (cdr (assq char perl-quote-like-pairs))) - (pos (point)) - (st (perl-quote-syntax-table char))) - (if (not close) - ;; The closing char is the same as the opening char. - (with-syntax-table st - (parse-partial-sexp (point) (point-max) - nil nil state 'syntax-table) - (when twoargs - (parse-partial-sexp (point) (point-max) - nil nil state 'syntax-table))) - ;; The open/close chars are matched like () [] {} and <>. - (let ((parse-sexp-lookup-properties nil)) - (condition-case err - (progn - (with-syntax-table st - (goto-char (nth 8 state)) (forward-sexp 1)) - (when twoargs - (save-excursion - ;; Skip whitespace and make sure that font-lock will - ;; refontify the second part in the proper context. - (put-text-property - (point) (progn (forward-comment (point-max)) (point)) - 'font-lock-multiline t) - ;; - (unless - (or (eobp) - (save-excursion - (with-syntax-table - (perl-quote-syntax-table (char-after)) - (forward-sexp 1)) - (put-text-property pos (line-end-position) - 'jit-lock-defer-multiline t) - (looking-at "\\s-*\\sw*e"))) - (put-text-property (point) (1+ (point)) - 'syntax-table - (if (assoc (char-after) - perl-quote-like-pairs) - '(15) '(7))))))) - ;; The arg(s) is not terminated, so it extends until EOB. - (scan-error (goto-char (point-max)))))) - ;; Point is now right after the arg(s). - ;; Erase any syntactic marks within the quoted text. - (put-text-property pos (1- (point)) 'syntax-table nil) - (when (eq (char-before (1- (point))) ?$) - (put-text-property (- (point) 2) (1- (point)) - 'syntax-table '(1))) - (put-text-property (1- (point)) (point) - 'syntax-table (if close '(15) '(7))))))) + (cond + ((or (null (setq char (nth 3 state))) + (and (characterp char) (eq (char-syntax (nth 3 state)) ?\"))) + ;; Normal text, or comment, or docstring, or normal string. + nil) + ((eq (nth 3 state) ?\n) + ;; A `format' command. + (when (re-search-forward "^\\s *\\.\\s *\n" limit 'move) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "\"")))) + (t + ;; This is regexp like quote thingy. + (setq char (char-after (nth 8 state))) + (let ((twoargs (save-excursion + (goto-char (nth 8 state)) + (skip-syntax-backward " ") + (skip-syntax-backward "w") + (member (buffer-substring + (point) (progn (forward-word 1) (point))) + '("tr" "s" "y")))) + (close (cdr (assq char perl-quote-like-pairs))) + (st (perl-quote-syntax-table char))) + (when (with-syntax-table st + (if close + ;; For paired delimiters, Perl allows nesting them, but + ;; since we treat them as strings, Emacs does not count + ;; those delimiters in `state', so we don't know how deep + ;; we are: we have to go back to the beginning of this + ;; "string" and count from there. + (condition-case nil + (progn + ;; Start after the first char since it doesn't have + ;; paren-syntax (an alternative would be to let-bind + ;; parse-sexp-lookup-properties). + (goto-char (1+ (nth 8 state))) + (up-list 1) + t) + (scan-error nil)) + (not (or (nth 8 (parse-partial-sexp + (point) limit nil nil state 'syntax-table)) + ;; If we have a self-paired opener and a twoargs + ;; command, the form is s/../../ so we have to skip + ;; a second time. + ;; In the case of s{...}{...}, we only handle the + ;; first part here and the next below. + (when (and twoargs (not close)) + (nth 8 (parse-partial-sexp + (point) limit + nil nil state 'syntax-table))))))) + ;; Point is now right after the arg(s). + (when (eq (char-before (1- (point))) ?$) + (put-text-property (- (point) 2) (1- (point)) + 'syntax-table '(1))) + (put-text-property (1- (point)) (point) + 'syntax-table + (if close + (string-to-syntax "|") + (string-to-syntax "\""))) + ;; If we have two args with a non-self-paired starter (e.g. + ;; s{...}{...}) we're right after the first arg, so we still have to + ;; handle the second part. + (when (and twoargs close) + ;; Skip whitespace and make sure that font-lock will + ;; refontify the second part in the proper context. + (put-text-property + (point) (progn (forward-comment (point-max)) (point)) + 'syntax-multiline t) + ;; + (when (< (point) limit) + (put-text-property (point) (1+ (point)) + 'syntax-table + (if (assoc (char-after) + perl-quote-like-pairs) + ;; Put an `e' in the cdr to mark this + ;; char as "second arg starter". + (string-to-syntax "|e") + (string-to-syntax "\"e"))) + (forward-char 1) + ;; Re-use perl-syntax-propertize-special-constructs to handle the + ;; second part (the first delimiter of second part can't be + ;; preceded by "s" or "tr" or "y", so it will not be considered + ;; as twoarg). + (perl-syntax-propertize-special-constructs limit))))))))) - (setq state (parse-partial-sexp (point) limit nil nil state - 'syntax-table)))) - ;; Tell font-lock that this needs not further processing. - nil) - +(defun perl-font-lock-syntactic-face-function (state) + (cond + ((and (nth 3 state) + (eq ?e (cdr-safe (get-text-property (nth 8 state) 'syntax-table))) + ;; This is a second-arg of s{..}{...} form; let's check if this second + ;; arg is executable code rather than a string. For that, we need to + ;; look for an "e" after this second arg, so we have to hunt for the + ;; end of the arg. Depending on whether the whole arg has already + ;; been syntax-propertized or not, the end-char will have different + ;; syntaxes, so let's ignore syntax-properties temporarily so we can + ;; pretend it has not been syntax-propertized yet. + (let* ((parse-sexp-lookup-properties nil) + (char (char-after (nth 8 state))) + (paired (assq char perl-quote-like-pairs))) + (with-syntax-table (perl-quote-syntax-table char) + (save-excursion + (if (not paired) + (parse-partial-sexp (point) (point-max) + nil nil state 'syntax-table) + (condition-case nil + (progn + (goto-char (1+ (nth 8 state))) + (up-list 1)) + (scan-error (goto-char (point-max))))) + (put-text-property (nth 8 state) (point) + 'jit-lock-defer-multiline t) + (looking-at "[ \t]*\\sw*e"))))) + nil) + (t (funcall (default-value 'font-lock-syntactic-face-function) state)))) (defcustom perl-indent-level 4 "*Indentation of Perl statements with respect to containing block." @@ -574,9 +619,12 @@ perl-font-lock-keywords-1 perl-font-lock-keywords-2) nil nil ((?\_ . "w")) nil - (font-lock-syntactic-keywords - . perl-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + (font-lock-syntactic-face-function + . perl-font-lock-syntactic-face-function))) + (set (make-local-variable 'syntax-propertize-function) + #'perl-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local) ;; Tell imenu how to handle Perl. (set (make-local-variable 'imenu-generic-expression) perl-imenu-generic-expression)
--- a/lisp/progmodes/prolog.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/prolog.el Wed Sep 22 15:46:51 2010 +0900 @@ -99,12 +99,36 @@ (defvar prolog-mode-abbrev-table nil) (define-abbrev-table 'prolog-mode-abbrev-table ()) +(defun prolog-smie-forward-token () + (forward-comment (point-max)) + (buffer-substring-no-properties + (point) + (progn (cond + ((looking-at "[!;]") (forward-char 1)) + ((not (zerop (skip-chars-forward "#&*+-./:<=>?@\\^`~")))) + ((not (zerop (skip-syntax-forward "w_'")))) + ;; In case of non-ASCII punctuation. + ((not (zerop (skip-syntax-forward "."))))) + (point)))) + +(defun prolog-smie-backward-token () + (forward-comment (- (point-max))) + (buffer-substring-no-properties + (point) + (progn (cond + ((memq (char-before) '(?! ?\;)) (forward-char -1)) + ((not (zerop (skip-chars-backward "#&*+-./:<=>?@\\^`~")))) + ((not (zerop (skip-syntax-backward "w_'")))) + ;; In case of non-ASCII punctuation. + ((not (zerop (skip-syntax-backward "."))))) + (point)))) + (defconst prolog-smie-op-levels ;; Rather than construct the operator levels table from the BNF, ;; we directly provide the operator precedences from GNU Prolog's - ;; manual. The only problem is that GNU Prolog's manual uses - ;; precedence levels in the opposite sense (higher numbers bind less - ;; tightly) than SMIE, so we use negative numbers. + ;; manual (7.14.10 op/3). The only problem is that GNU Prolog's + ;; manual uses precedence levels in the opposite sense (higher + ;; numbers bind less tightly) than SMIE, so we use negative numbers. '(("." -10000 -10000) (":-" -1200 -1200) ("-->" -1200 -1200) @@ -162,9 +186,18 @@ (make-local-variable 'imenu-generic-expression) (setq imenu-generic-expression '((nil "^\\sw+" 0))) (smie-setup prolog-smie-op-levels prolog-smie-indent-rules) + (set (make-local-variable 'smie-forward-token-function) + #'prolog-smie-forward-token) + (set (make-local-variable 'smie-backward-token-function) + #'prolog-smie-backward-token) (set (make-local-variable 'forward-sexp-function) 'smie-forward-sexp-command) (set (make-local-variable 'smie-indent-basic) prolog-indent-width) + (set (make-local-variable 'smie-blink-matching-triggers) '(?.)) + (set (make-local-variable 'smie-closer-alist) '((t . "."))) + (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) + ;; There's no real closer in Prolog anyway. + (set (make-local-variable 'smie-blink-matching-inners) t) (make-local-variable 'comment-start) (setq comment-start "%") (make-local-variable 'comment-start-skip)
--- a/lisp/progmodes/python.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/python.el Wed Sep 22 15:46:51 2010 +0900 @@ -166,29 +166,32 @@ symbol-end) . font-lock-builtin-face))) -(defconst python-font-lock-syntactic-keywords +(defconst python-syntax-propertize-function ;; Make outer chars of matching triple-quote sequences into generic ;; string delimiters. Fixme: Is there a better way? ;; First avoid a sequence preceded by an odd number of backslashes. - `((,(rx (not (any ?\\)) - ?\\ (* (and ?\\ ?\\)) - (group (syntax string-quote)) - (backref 1) - (group (backref 1))) - (2 ,(string-to-syntax "\""))) ; dummy - (,(rx (group (optional (any "uUrR"))) ; prefix gets syntax property - (optional (any "rR")) ; possible second prefix - (group (syntax string-quote)) ; maybe gets property - (backref 2) ; per first quote - (group (backref 2))) ; maybe gets property - (1 (python-quote-syntax 1)) - (2 (python-quote-syntax 2)) - (3 (python-quote-syntax 3))) - ;; This doesn't really help. -;;; (,(rx (and ?\\ (group ?\n))) (1 " ")) - )) + (syntax-propertize-rules + (;; (rx (not (any ?\\)) + ;; ?\\ (* (and ?\\ ?\\)) + ;; (group (syntax string-quote)) + ;; (backref 1) + ;; (group (backref 1))) + ;; ¡Backrefs don't work in syntax-propertize-rules! + "[^\\]\\\\\\(\\\\\\\\\\)*\\(?:''\\('\\)\\|\"\"\\(?2:\"\\)\\)" + (2 "\"")) ; dummy + (;; (rx (optional (group (any "uUrR"))) ; prefix gets syntax property + ;; (optional (any "rR")) ; possible second prefix + ;; (group (syntax string-quote)) ; maybe gets property + ;; (backref 2) ; per first quote + ;; (group (backref 2))) ; maybe gets property + ;; ¡Backrefs don't work in syntax-propertize-rules! + "\\([RUru]\\)?[Rr]?\\(?:\\('\\)'\\('\\)\\|\\(?2:\"\\)\"\\(?3:\"\\)\\)" + (3 (ignore (python-quote-syntax)))) + ;; This doesn't really help. + ;;((rx (and ?\\ (group ?\n))) (1 " ")) + )) -(defun python-quote-syntax (n) +(defun python-quote-syntax () "Put `syntax-table' property correctly on triple quote. Used for syntactic keywords. N is the match number (1, 2 or 3)." ;; Given a triple quote, we have to check the context to know @@ -206,28 +209,25 @@ ;; x '"""' x """ \"""" x (save-excursion (goto-char (match-beginning 0)) - (cond - ;; Consider property for the last char if in a fenced string. - ((= n 3) - (let* ((font-lock-syntactic-keywords nil) - (syntax (syntax-ppss))) - (when (eq t (nth 3 syntax)) ; after unclosed fence - (goto-char (nth 8 syntax)) ; fence position - (skip-chars-forward "uUrR") ; skip any prefix - ;; Is it a matching sequence? - (if (eq (char-after) (char-after (match-beginning 2))) - (eval-when-compile (string-to-syntax "|")))))) - ;; Consider property for initial char, accounting for prefixes. - ((or (and (= n 2) ; leading quote (not prefix) - (= (match-beginning 1) (match-end 1))) ; prefix is null - (and (= n 1) ; prefix - (/= (match-beginning 1) (match-end 1)))) ; non-empty - (let ((font-lock-syntactic-keywords nil)) - (unless (eq 'string (syntax-ppss-context (syntax-ppss))) - (eval-when-compile (string-to-syntax "|"))))) - ;; Otherwise (we're in a non-matching string) the property is - ;; nil, which is OK. - ))) + (let ((syntax (save-match-data (syntax-ppss)))) + (cond + ((eq t (nth 3 syntax)) ; after unclosed fence + ;; Consider property for the last char if in a fenced string. + (goto-char (nth 8 syntax)) ; fence position + (skip-chars-forward "uUrR") ; skip any prefix + ;; Is it a matching sequence? + (if (eq (char-after) (char-after (match-beginning 2))) + (put-text-property (match-beginning 3) (match-end 3) + 'syntax-table (string-to-syntax "|")))) + ((match-end 1) + ;; Consider property for initial char, accounting for prefixes. + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "|"))) + (t + ;; Consider property for initial char, accounting for prefixes. + (put-text-property (match-beginning 2) (match-end 2) + 'syntax-table (string-to-syntax "|")))) + ))) ;; This isn't currently in `font-lock-defaults' as probably not worth ;; it -- we basically only mess with a few normally-symbol characters. @@ -2495,12 +2495,12 @@ :group 'python (set (make-local-variable 'font-lock-defaults) '(python-font-lock-keywords nil nil nil nil - (font-lock-syntactic-keywords - . python-font-lock-syntactic-keywords) - ;; This probably isn't worth it. - ;; (font-lock-syntactic-face-function - ;; . python-font-lock-syntactic-face-function) - )) + ;; This probably isn't worth it. + ;; (font-lock-syntactic-face-function + ;; . python-font-lock-syntactic-face-function) + )) + (set (make-local-variable 'syntax-propertize-function) + python-syntax-propertize-function) (set (make-local-variable 'parse-sexp-lookup-properties) t) (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'comment-start) "# ")
--- a/lisp/progmodes/ruby-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/ruby-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -100,17 +100,10 @@ (defconst ruby-block-end-re "\\<end\\>") -(defconst ruby-here-doc-beg-re +(eval-and-compile + (defconst ruby-here-doc-beg-re "\\(<\\)<\\(-\\)?\\(\\([a-zA-Z0-9_]+\\)\\|[\"]\\([^\"]+\\)[\"]\\|[']\\([^']+\\)[']\\)" - "Regexp to match the beginning of a heredoc.") - -(defconst ruby-here-doc-end-re - "^\\([ \t]+\\)?\\(.*\\)\\(.\\)$" - "Regexp to match the end of heredocs. - -This will actually match any line with one or more characters. -It's useful in that it divides up the match string so that -`ruby-here-doc-beg-match' can search for the beginning of the heredoc.") + "Regexp to match the beginning of a heredoc.")) (defun ruby-here-doc-end-match () "Return a regexp to find the end of a heredoc. @@ -123,18 +116,6 @@ (match-string 5) (match-string 6))))) -(defun ruby-here-doc-beg-match () - "Return a regexp to find the beginning of a heredoc. - -This should only be called after matching against `ruby-here-doc-end-re'." - (let ((contents (regexp-quote (concat (match-string 2) (match-string 3))))) - (concat "<<" - (let ((match (match-string 1))) - (if (and match (> (length match) 0)) - (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" (match-string 1) "\\)" - contents "\\b\\(\\1\\|\\2\\)") - (concat "-?\\([\"']\\|\\)" contents "\\b\\1")))))) - (defconst ruby-delimiter (concat "[?$/%(){}#\"'`.:]\\|<<\\|\\[\\|\\]\\|\\<\\(" ruby-block-beg-re @@ -362,7 +343,7 @@ (back-to-indentation) (current-column))) -(defun ruby-indent-line (&optional flag) +(defun ruby-indent-line (&optional ignored) "Correct the indentation of the current Ruby line." (interactive) (ruby-indent-to (ruby-calculate-indent))) @@ -405,8 +386,7 @@ "TODO: document." (save-excursion (store-match-data nil) - (let ((space (skip-chars-backward " \t")) - (start (point))) + (let ((space (skip-chars-backward " \t"))) (cond ((bolp) t) ((progn @@ -700,7 +680,7 @@ (beginning-of-line) (let ((ruby-indent-point (point)) (case-fold-search nil) - state bol eol begin op-end + state eol begin op-end (paren (progn (skip-syntax-forward " ") (and (char-after) (matching-paren (char-after))))) (indent 0)) @@ -780,7 +760,6 @@ (if (re-search-forward "^\\s *#" end t) (beginning-of-line) (setq done t)))) - (setq bol (point)) (end-of-line) ;; skip the comment at the end (skip-chars-backward " \t") @@ -1037,10 +1016,8 @@ (ruby-beginning-of-defun) (re-search-backward "^\n" (- (point) 1) t)) -(defun ruby-indent-exp (&optional shutup-p) - "Indent each line in the balanced expression following the point. -If a prefix arg is given or SHUTUP-P is non-nil, no errors -are signalled if a balanced expression isn't found." +(defun ruby-indent-exp (&optional ignored) + "Indent each line in the balanced expression following the point." (interactive "*P") (let ((here (point-marker)) start top column (nest t)) (set-marker-insertion-type here t) @@ -1133,58 +1110,208 @@ (if mlist (concat mlist mname) mname) mlist))))) -(defconst ruby-font-lock-syntactic-keywords - `(;; #{ }, #$hoge, #@foo are not comments - ("\\(#\\)[{$@]" 1 (1 . nil)) - ;; the last $', $", $` in the respective string is not variable - ;; the last ?', ?", ?` in the respective string is not ascii code - ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" - (2 (7 . nil)) - (4 (7 . nil))) - ;; $' $" $` .... are variables - ;; ?' ?" ?` are ascii codes - ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil)) - ;; regexps - ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" - (4 (7 . ?/)) - (6 (7 . ?/))) - ("^=en\\(d\\)\\_>" 1 "!") - ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax)) - ;; Currently, the following case is highlighted incorrectly: - ;; - ;; <<FOO - ;; FOO - ;; <<BAR - ;; <<BAZ - ;; BAZ - ;; BAR - ;; - ;; This is because all here-doc beginnings are highlighted before any endings, - ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ - ;; it thinks <<BAR is part of a string so it's marked as well. - ;; - ;; This may be fixable by modifying ruby-in-here-doc-p to use - ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context, - ;; but I don't want to try that until we've got unit tests set up - ;; to make sure I don't break anything else. - (,(concat ruby-here-doc-beg-re ".*\\(\n\\)") - ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re)) - (ruby-here-doc-beg-syntax)) - (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax))) - "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.") +(if (eval-when-compile (fboundp #'syntax-propertize-rules)) + ;; New code that works independently from font-lock. + (progn + (defun ruby-syntax-propertize-function (start end) + "Syntactic keywords for Ruby mode. See `syntax-propertize-function'." + (goto-char start) + (ruby-syntax-propertize-heredoc end) + (funcall + (syntax-propertize-rules + ;; #{ }, #$hoge, #@foo are not comments + ("\\(#\\)[{$@]" (1 ".")) + ;; the last $', $", $` in the respective string is not variable + ;; the last ?', ?", ?` in the respective string is not ascii code + ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" + (2 "\"") + (4 "\"")) + ;; $' $" $` .... are variables + ;; ?' ?" ?` are ascii codes + ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" (3 ".")) + ;; regexps + ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" + (4 "\"/") + (6 "\"/")) + ("^=en\\(d\\)\\_>" (1 "!")) + ("^\\(=\\)begin\\_>" (1 "!")) + ;; Handle here documents. + ((concat ruby-here-doc-beg-re ".*\\(\n\\)") + (7 (prog1 "\"" (ruby-syntax-propertize-heredoc end))))) + (point) end)) + + (defun ruby-syntax-propertize-heredoc (limit) + (let ((ppss (syntax-ppss)) + (res '())) + (when (eq ?\n (nth 3 ppss)) + (save-excursion + (goto-char (nth 8 ppss)) + (beginning-of-line) + (while (re-search-forward ruby-here-doc-beg-re + (line-end-position) t) + (push (concat (ruby-here-doc-end-match) "\n") res))) + (let ((start (point))) + ;; With multiple openers on the same line, we don't know in which + ;; part `start' is, so we have to go back to the beginning. + (when (cdr res) + (goto-char (nth 8 ppss)) + (setq res (nreverse res))) + (while (and res (re-search-forward (pop res) limit 'move)) + (if (null res) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "\"")))) + ;; Make extra sure we don't move back, lest we could fall into an + ;; inf-loop. + (if (< (point) start) (goto-char start)))))) + ) + + ;; For Emacsen where syntax-propertize-rules is not (yet) available, + ;; fallback on the old font-lock-syntactic-keywords stuff. -(defun ruby-comment-beg-syntax () - "Return the syntax cell for a the first character of a =begin. + (defconst ruby-here-doc-end-re + "^\\([ \t]+\\)?\\(.*\\)\\(\n\\)" + "Regexp to match the end of heredocs. + +This will actually match any line with one or more characters. +It's useful in that it divides up the match string so that +`ruby-here-doc-beg-match' can search for the beginning of the heredoc.") + + (defun ruby-here-doc-beg-match () + "Return a regexp to find the beginning of a heredoc. + +This should only be called after matching against `ruby-here-doc-end-re'." + (let ((contents (regexp-quote (match-string 2)))) + (concat "<<" + (let ((match (match-string 1))) + (if (and match (> (length match) 0)) + (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" match "\\)" + contents "\\b\\(\\1\\|\\2\\)") + (concat "-?\\([\"']\\|\\)" contents "\\b\\1")))))) + + (defconst ruby-font-lock-syntactic-keywords + `( ;; #{ }, #$hoge, #@foo are not comments + ("\\(#\\)[{$@]" 1 (1 . nil)) + ;; the last $', $", $` in the respective string is not variable + ;; the last ?', ?", ?` in the respective string is not ascii code + ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" + (2 (7 . nil)) + (4 (7 . nil))) + ;; $' $" $` .... are variables + ;; ?' ?" ?` are ascii codes + ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil)) + ;; regexps + ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" + (4 (7 . ?/)) + (6 (7 . ?/))) + ("^=en\\(d\\)\\_>" 1 "!") + ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax)) + ;; Currently, the following case is highlighted incorrectly: + ;; + ;; <<FOO + ;; FOO + ;; <<BAR + ;; <<BAZ + ;; BAZ + ;; BAR + ;; + ;; This is because all here-doc beginnings are highlighted before any endings, + ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ + ;; it thinks <<BAR is part of a string so it's marked as well. + ;; + ;; This may be fixable by modifying ruby-in-here-doc-p to use + ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context, + ;; but I don't want to try that until we've got unit tests set up + ;; to make sure I don't break anything else. + (,(concat ruby-here-doc-beg-re ".*\\(\n\\)") + ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re)) + (ruby-here-doc-beg-syntax)) + (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax))) + "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.") + + (defun ruby-comment-beg-syntax () + "Return the syntax cell for a the first character of a =begin. See the definition of `ruby-font-lock-syntactic-keywords'. This returns a comment-delimiter cell as long as the =begin isn't in a string or another comment." - (when (not (nth 3 (syntax-ppss))) - (string-to-syntax "!"))) + (when (not (nth 3 (syntax-ppss))) + (string-to-syntax "!"))) + + (defun ruby-in-here-doc-p () + "Return whether or not the point is in a heredoc." + (save-excursion + (let ((old-point (point)) (case-fold-search nil)) + (beginning-of-line) + (catch 'found-beg + (while (re-search-backward ruby-here-doc-beg-re nil t) + (if (not (or (ruby-in-ppss-context-p 'anything) + (ruby-here-doc-find-end old-point))) + (throw 'found-beg t))))))) + + (defun ruby-here-doc-find-end (&optional limit) + "Expects the point to be on a line with one or more heredoc openers. +Returns the buffer position at which all heredocs on the line +are terminated, or nil if they aren't terminated before the +buffer position `limit' or the end of the buffer." + (save-excursion + (beginning-of-line) + (catch 'done + (let ((eol (save-excursion (end-of-line) (point))) + (case-fold-search nil) + ;; Fake match data such that (match-end 0) is at eol + (end-match-data (progn (looking-at ".*$") (match-data))) + beg-match-data end-re) + (while (re-search-forward ruby-here-doc-beg-re eol t) + (setq beg-match-data (match-data)) + (setq end-re (ruby-here-doc-end-match)) + + (set-match-data end-match-data) + (goto-char (match-end 0)) + (unless (re-search-forward end-re limit t) (throw 'done nil)) + (setq end-match-data (match-data)) -(unless (functionp 'syntax-ppss) - (defun syntax-ppss (&optional pos) - (parse-partial-sexp (point-min) (or pos (point))))) + (set-match-data beg-match-data) + (goto-char (match-end 0))) + (set-match-data end-match-data) + (goto-char (match-end 0)) + (point))))) + + (defun ruby-here-doc-beg-syntax () + "Return the syntax cell for a line that may begin a heredoc. +See the definition of `ruby-font-lock-syntactic-keywords'. + +This sets the syntax cell for the newline ending the line +containing the heredoc beginning so that cases where multiple +heredocs are started on one line are handled correctly." + (save-excursion + (goto-char (match-beginning 0)) + (unless (or (ruby-in-ppss-context-p 'non-heredoc) + (ruby-in-here-doc-p)) + (string-to-syntax "\"")))) + + (defun ruby-here-doc-end-syntax () + "Return the syntax cell for a line that may end a heredoc. +See the definition of `ruby-font-lock-syntactic-keywords'." + (let ((pss (syntax-ppss)) (case-fold-search nil)) + ;; If we aren't in a string, we definitely aren't ending a heredoc, + ;; so we can just give up. + ;; This means we aren't doing a full-document search + ;; every time we enter a character. + (when (ruby-in-ppss-context-p 'heredoc pss) + (save-excursion + (goto-char (nth 8 pss)) ; Go to the beginning of heredoc. + (let ((eol (point))) + (beginning-of-line) + (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line... + (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment... + (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line... + (not (re-search-forward ruby-here-doc-beg-re eol t)))) + (string-to-syntax "\""))))))) + + (unless (functionp 'syntax-ppss) + (defun syntax-ppss (&optional pos) + (parse-partial-sexp (point-min) (or pos (point))))) + ) (defun ruby-in-ppss-context-p (context &optional ppss) (let ((ppss (or ppss (syntax-ppss (point))))) @@ -1195,10 +1322,7 @@ ((eq context 'string) (nth 3 ppss)) ((eq context 'heredoc) - (and (nth 3 ppss) - ;; If it's generic string, it's a heredoc and we don't care - ;; See `parse-partial-sexp' - (not (numberp (nth 3 ppss))))) + (eq ?\n (nth 3 ppss))) ((eq context 'non-heredoc) (and (ruby-in-ppss-context-p 'anything) (not (ruby-in-ppss-context-p 'heredoc)))) @@ -1210,77 +1334,6 @@ "context name `" (symbol-name context) "' is unknown")))) t))) -(defun ruby-in-here-doc-p () - "Return whether or not the point is in a heredoc." - (save-excursion - (let ((old-point (point)) (case-fold-search nil)) - (beginning-of-line) - (catch 'found-beg - (while (re-search-backward ruby-here-doc-beg-re nil t) - (if (not (or (ruby-in-ppss-context-p 'anything) - (ruby-here-doc-find-end old-point))) - (throw 'found-beg t))))))) - -(defun ruby-here-doc-find-end (&optional limit) - "Expects the point to be on a line with one or more heredoc openers. -Returns the buffer position at which all heredocs on the line -are terminated, or nil if they aren't terminated before the -buffer position `limit' or the end of the buffer." - (save-excursion - (beginning-of-line) - (catch 'done - (let ((eol (save-excursion (end-of-line) (point))) - (case-fold-search nil) - ;; Fake match data such that (match-end 0) is at eol - (end-match-data (progn (looking-at ".*$") (match-data))) - beg-match-data end-re) - (while (re-search-forward ruby-here-doc-beg-re eol t) - (setq beg-match-data (match-data)) - (setq end-re (ruby-here-doc-end-match)) - - (set-match-data end-match-data) - (goto-char (match-end 0)) - (unless (re-search-forward end-re limit t) (throw 'done nil)) - (setq end-match-data (match-data)) - - (set-match-data beg-match-data) - (goto-char (match-end 0))) - (set-match-data end-match-data) - (goto-char (match-end 0)) - (point))))) - -(defun ruby-here-doc-beg-syntax () - "Return the syntax cell for a line that may begin a heredoc. -See the definition of `ruby-font-lock-syntactic-keywords'. - -This sets the syntax cell for the newline ending the line -containing the heredoc beginning so that cases where multiple -heredocs are started on one line are handled correctly." - (save-excursion - (goto-char (match-beginning 0)) - (unless (or (ruby-in-ppss-context-p 'non-heredoc) - (ruby-in-here-doc-p)) - (string-to-syntax "|")))) - -(defun ruby-here-doc-end-syntax () - "Return the syntax cell for a line that may end a heredoc. -See the definition of `ruby-font-lock-syntactic-keywords'." - (let ((pss (syntax-ppss)) (case-fold-search nil)) - ;; If we aren't in a string, we definitely aren't ending a heredoc, - ;; so we can just give up. - ;; This means we aren't doing a full-document search - ;; every time we enter a character. - (when (ruby-in-ppss-context-p 'heredoc pss) - (save-excursion - (goto-char (nth 8 pss)) ; Go to the beginning of heredoc. - (let ((eol (point))) - (beginning-of-line) - (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line... - (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment... - (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line... - (not (re-search-forward ruby-here-doc-beg-re eol t)))) - (string-to-syntax "|"))))))) - (if (featurep 'xemacs) (put 'ruby-mode 'font-lock-defaults '((ruby-font-lock-keywords) @@ -1377,8 +1430,10 @@ ) "Additional expressions to highlight in Ruby mode.") +(defvar electric-indent-chars) + ;;;###autoload -(defun ruby-mode () +(define-derived-mode ruby-mode prog-mode "Ruby" "Major mode for editing Ruby scripts. \\[ruby-indent-line] properly indents subexpressions of multi-line class, module, def, if, while, for, do, and case statements, taking @@ -1387,27 +1442,22 @@ The variable `ruby-indent-level' controls the amount of indentation. \\{ruby-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ruby-mode-map) - (setq mode-name "Ruby") - (setq major-mode 'ruby-mode) (ruby-mode-variables) - (set (make-local-variable 'indent-line-function) - 'ruby-indent-line) (set (make-local-variable 'imenu-create-index-function) 'ruby-imenu-create-index) (set (make-local-variable 'add-log-current-defun-function) 'ruby-add-log-current-method) (add-hook - (cond ((boundp 'before-save-hook) - (make-local-variable 'before-save-hook) - 'before-save-hook) + (cond ((boundp 'before-save-hook) 'before-save-hook) ((boundp 'write-contents-functions) 'write-contents-functions) ((boundp 'write-contents-hooks) 'write-contents-hooks)) - 'ruby-mode-set-encoding) + 'ruby-mode-set-encoding nil 'local) + + (set (make-local-variable 'electric-indent-chars) + (append '(?\{ ?\}) (if (boundp 'electric-indent-chars) + (default-value 'electric-indent-chars)))) (set (make-local-variable 'font-lock-defaults) '((ruby-font-lock-keywords) nil nil)) @@ -1415,12 +1465,12 @@ ruby-font-lock-keywords) (set (make-local-variable 'font-lock-syntax-table) ruby-font-lock-syntax-table) - (set (make-local-variable 'font-lock-syntactic-keywords) - ruby-font-lock-syntactic-keywords) - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'ruby-mode-hook) - (run-hooks 'ruby-mode-hook))) + (if (eval-when-compile (fboundp 'syntax-propertize-rules)) + (set (make-local-variable 'syntax-propertize-function) + #'ruby-syntax-propertize-function) + (set (make-local-variable 'font-lock-syntactic-keywords) + ruby-font-lock-syntactic-keywords))) ;;; Invoke ruby-mode when appropriate
--- a/lisp/progmodes/sh-script.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/sh-script.el Wed Sep 22 15:46:51 2010 +0900 @@ -939,7 +939,6 @@ ;; These are used for the syntax table stuff (derived from cperl-mode). ;; Note: parse-sexp-lookup-properties must be set to t for it to work. (defconst sh-st-punc (string-to-syntax ".")) -(defconst sh-st-symbol (string-to-syntax "_")) (defconst sh-here-doc-syntax (string-to-syntax "|")) ;; generic string (defconst sh-escaped-line-re @@ -957,7 +956,7 @@ (defvar sh-here-doc-re sh-here-doc-open-re) (make-variable-buffer-local 'sh-here-doc-re) -(defun sh-font-lock-close-heredoc (bol eof indented) +(defun sh-font-lock-close-heredoc (bol eof indented eol) "Determine the syntax of the \\n after an EOF. If non-nil INDENTED indicates that the EOF was indented." (let* ((eof-re (if eof (regexp-quote eof) "")) @@ -971,6 +970,8 @@ (ere (concat "^" (if indented "[ \t]*") eof-re "\n")) (start (save-excursion (goto-char bol) + ;; FIXME: will incorrectly find a <<EOF embedded inside + ;; the heredoc. (re-search-backward (concat sre "\\|" ere) nil t)))) ;; If subgroup 1 matched, we found an open-heredoc, otherwise we first ;; found a close-heredoc which makes the current close-heredoc inoperant. @@ -990,7 +991,7 @@ (sh-in-comment-or-string (point))))) ;; No <<EOF2 found after our <<. (= (point) start))) - sh-here-doc-syntax) + (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax)) ((not (or start (save-excursion (re-search-forward sre nil t)))) ;; There's no <<EOF either before or after us, ;; so we should remove ourselves from font-lock's keywords. @@ -1000,7 +1001,7 @@ (regexp-opt sh-here-doc-markers t) "\\(\n\\)")) nil)))) -(defun sh-font-lock-open-heredoc (start string) +(defun sh-font-lock-open-heredoc (start string eol) "Determine the syntax of the \\n after a <<EOF. START is the position of <<. STRING is the actual word used as delimiter (e.g. \"EOF\"). @@ -1030,13 +1031,8 @@ ;; Don't bother fixing it now, but place a multiline property so ;; that when jit-lock-context-* refontifies the rest of the ;; buffer, it also refontifies the current line with it. - (put-text-property start (point) 'font-lock-multiline t))) - sh-here-doc-syntax)) - -(defun sh-font-lock-here-doc (limit) - "Search for a heredoc marker." - ;; This looks silly, but it's because `sh-here-doc-re' keeps changing. - (re-search-forward sh-here-doc-re limit t)) + (put-text-property start (point) 'syntax-multiline t))) + (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax))) (defun sh-font-lock-quoted-subshell (limit) "Search for a subshell embedded in a string. @@ -1045,9 +1041,7 @@ ;; FIXME: This can (and often does) match multiple lines, yet it makes no ;; effort to handle multiline cases correctly, so it ends up being ;; rather flakey. - (when (and (re-search-forward "\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)" limit t) - ;; Make sure the " we matched is an opening quote. - (eq ?\" (nth 3 (syntax-ppss)))) + (when (eq ?\" (nth 3 (syntax-ppss))) ; Check we matched an opening quote. ;; bingo we have a $( or a ` inside a "" (let ((char (char-after (point))) ;; `state' can be: double-quote, backquote, code. @@ -1082,8 +1076,7 @@ (double-quote nil) (t (setq state (pop states))))) (t (error "Internal error in sh-font-lock-quoted-subshell"))) - (forward-char 1))) - t)) + (forward-char 1))))) (defun sh-is-quoted-p (pos) @@ -1122,7 +1115,7 @@ (when (progn (backward-char 2) (if (> start (line-end-position)) (put-text-property (point) (1+ start) - 'font-lock-multiline t)) + 'syntax-multiline t)) ;; FIXME: The `in' may just be a random argument to ;; a normal command rather than the real `in' keyword. ;; I.e. we should look back to try and find the @@ -1136,40 +1129,44 @@ sh-st-punc nil)) -(defun sh-font-lock-flush-syntax-ppss-cache (limit) - ;; This should probably be a standard function provided by font-lock.el - ;; (or syntax.el). - (syntax-ppss-flush-cache (point)) - (goto-char limit) - nil) - -(defconst sh-font-lock-syntactic-keywords - ;; A `#' begins a comment when it is unquoted and at the beginning of a - ;; word. In the shell, words are separated by metacharacters. - ;; The list of special chars is taken from the single-unix spec - ;; of the shell command language (under `quoting') but with `$' removed. - `(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 ,sh-st-symbol) - ;; In a '...' the backslash is not escaping. - ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote))) - ;; The previous rule uses syntax-ppss, but the subsequent rules may - ;; change the syntax, so we have to tell syntax-ppss that the states it - ;; has just computed will need to be recomputed. - (sh-font-lock-flush-syntax-ppss-cache) - ;; Make sure $@ and $? are correctly recognized as sexps. - ("\\$\\([?@]\\)" 1 ,sh-st-symbol) - ;; Find HEREDOC starters and add a corresponding rule for the ender. - (sh-font-lock-here-doc - (2 (sh-font-lock-open-heredoc - (match-beginning 0) (match-string 1)) nil t) - (5 (sh-font-lock-close-heredoc - (match-beginning 0) (match-string 4) - (and (match-beginning 3) (/= (match-beginning 3) (match-end 3)))) - nil t)) - ;; Distinguish the special close-paren in `case'. - (")" 0 (sh-font-lock-paren (match-beginning 0))) - ;; highlight (possibly nested) subshells inside "" quoted regions correctly. - ;; This should be at the very end because it uses syntax-ppss. - (sh-font-lock-quoted-subshell))) +(defun sh-syntax-propertize-function (start end) + (goto-char start) + (while (prog1 + (re-search-forward sh-here-doc-re end 'move) + (save-excursion + (save-match-data + (funcall + (syntax-propertize-rules + ;; A `#' begins a comment when it is unquoted and at the + ;; beginning of a word. In the shell, words are separated by + ;; metacharacters. The list of special chars is taken from + ;; the single-unix spec of the shell command language (under + ;; `quoting') but with `$' removed. + ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_")) + ;; In a '...' the backslash is not escaping. + ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote))) + ;; Make sure $@ and $? are correctly recognized as sexps. + ("\\$\\([?@]\\)" (1 "_")) + ;; Distinguish the special close-paren in `case'. + (")" (0 (sh-font-lock-paren (match-beginning 0)))) + ;; Highlight (possibly nested) subshells inside "" quoted + ;; regions correctly. + ("\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)" + (1 (ignore + ;; Save excursion because we want to also apply other + ;; syntax-propertize rules within the affected region. + (save-excursion + (sh-font-lock-quoted-subshell end)))))) + (prog1 start (setq start (point))) (point))))) + (if (match-beginning 2) + ;; FIXME: actually, once we see an heredoc opener, we should just + ;; search for its ender without propertizing anything in it. + (sh-font-lock-open-heredoc + (match-beginning 0) (match-string 1) (match-beginning 2)) + (sh-font-lock-close-heredoc + (match-beginning 0) (match-string 4) + (and (match-beginning 3) (/= (match-beginning 3) (match-end 3))) + (match-beginning 5))))) (defun sh-font-lock-syntactic-face-function (state) (let ((q (nth 3 state))) @@ -1553,9 +1550,12 @@ sh-font-lock-keywords-1 sh-font-lock-keywords-2) nil nil ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil - (font-lock-syntactic-keywords . sh-font-lock-syntactic-keywords) (font-lock-syntactic-face-function . sh-font-lock-syntactic-face-function))) + (set (make-local-variable 'syntax-propertize-function) + #'sh-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local) (set (make-local-variable 'skeleton-pair-alist) '((?` _ ?`))) (set (make-local-variable 'skeleton-pair-filter-function) 'sh-quoted-p) (set (make-local-variable 'skeleton-further-elements)
--- a/lisp/progmodes/simula.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/simula.el Wed Sep 22 15:46:51 2010 +0900 @@ -163,17 +163,18 @@ (defvar simula-mode-syntax-table nil "Syntax table in SIMULA mode buffers.") -(defconst simula-font-lock-syntactic-keywords - `(;; `comment' directive. - ("\\<\\(c\\)omment\\>" 1 "<") - ;; end comments - (,(concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|" - (regexp-opt '("end" "else" "when" "otherwise")) - "\\)\\)") - (1 "< b") - (3 "> b" nil t)) - ;; non-quoted single-quote char. - ("'\\('\\)'" 1 "."))) +(defconst simula-syntax-propertize-function + (syntax-propertize-rules + ;; `comment' directive. + ("\\<\\(c\\)omment\\>" (1 "<")) + ;; end comments + ((concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|" + (regexp-opt '("end" "else" "when" "otherwise")) + "\\)\\)") + (1 "< b") + (3 "> b")) + ;; non-quoted single-quote char. + ("'\\('\\)'" (1 ".")))) ;; Regexps written with help from Alf-Ivar Holm <alfh@ifi.uio.no>. (defconst simula-font-lock-keywords-1 @@ -396,8 +397,9 @@ (setq font-lock-defaults '((simula-font-lock-keywords simula-font-lock-keywords-1 simula-font-lock-keywords-2 simula-font-lock-keywords-3) - nil t ((?_ . "w")) nil - (font-lock-syntactic-keywords . simula-font-lock-syntactic-keywords))) + nil t ((?_ . "w")))) + (set (make-local-variable 'syntax-propertize-function) + simula-syntax-propertize-function) (abbrev-mode 1)) (defun simula-indent-exp ()
--- a/lisp/progmodes/sql.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/sql.el Wed Sep 22 15:46:51 2010 +0900 @@ -5,10 +5,9 @@ ;; Author: Alex Schroeder <alex@gnu.org> ;; Maintainer: Michael Mauger <mmaug@yahoo.com> -;; Version: 2.5 +;; Version: 2.8 ;; Keywords: comm languages processes ;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el -;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode ;; This file is part of GNU Emacs. @@ -187,10 +186,10 @@ ;; 6) Define a convienence function to invoke the SQL interpreter. -;; (defun my-sql-xyz () +;; (defun my-sql-xyz (&optional buffer) ;; "Run ixyz by XyzDB as an inferior process." -;; (interactive) -;; (sql-product-interactive 'xyz)) +;; (interactive "P") +;; (sql-product-interactive 'xyz buffer)) ;;; To Do: @@ -275,8 +274,8 @@ :group 'SQL :safe 'stringp) -(defcustom sql-port nil - "Default server or host." +(defcustom sql-port 0 + "Default port." :version "24.1" :type 'number :group 'SQL @@ -286,6 +285,9 @@ (define-widget 'sql-login-params 'lazy "Widget definition of the login parameters list" + ;; FIXME: does not implement :default property for the user, + ;; database and server options. Anybody have some guidance on how to + ;; do this. :tag "Login Parameters" :type '(repeat (choice (const user) @@ -300,7 +302,7 @@ (const :format "" server) (const :format "" :completion) (restricted-sexp - :match-alternatives (listp symbolp)))) + :match-alternatives (listp stringp)))) (choice :tag "database" (const database) (list :tag "file" @@ -311,7 +313,7 @@ (const :format "" database) (const :format "" :completion) (restricted-sexp - :match-alternatives (listp symbolp)))) + :match-alternatives (listp stringp)))) (const port)))) ;; SQL Product support @@ -401,6 +403,8 @@ :sqli-options sql-mysql-options :sqli-login sql-mysql-login-params :sqli-comint-func sql-comint-mysql + :list-all "SHOW TABLES;" + :list-table "DESCRIBE %s;" :prompt-regexp "^mysql> " :prompt-length 6 :prompt-cont-regexp "^ -> " @@ -428,11 +432,13 @@ :sqli-options sql-postgres-options :sqli-login sql-postgres-login-params :sqli-comint-func sql-comint-postgres + :list-all ("\\d+" . "\\dS+") + :list-table ("\\d+ %s" . "\\dS+ %s") :prompt-regexp "^.*=[#>] " :prompt-length 5 - :prompt-cont-regexp "^.*-[#>] " + :prompt-cont-regexp "^.*[-(][#>] " :input-filter sql-remove-tabs-filter - :terminator ("\\(^[\\]g\\|;\\)" . ";")) + :terminator ("\\(^\\s-*\\\\g\\|;\\)" . ";")) (solid :name "Solid" @@ -452,6 +458,8 @@ :sqli-options sql-sqlite-options :sqli-login sql-sqlite-login-params :sqli-comint-func sql-comint-sqlite + :list-all ".tables" + :list-table ".schema %s" :prompt-regexp "^sqlite> " :prompt-length 8 :prompt-cont-regexp "^ ...> " @@ -510,6 +518,23 @@ database. Do product specific configuration of comint in this function. + :list-all Command string or function which produces + a listing of all objects in the database. + If it's a cons cell, then the car + produces the standard list of objects and + the cdr produces an enhanced list of + objects. What \"enhanced\" means is + dependent on the SQL product and may not + exist. In general though, the + \"enhanced\" list should include visible + objects from other schemas. + + :list-table Command string or function which produces + a detailed listing of a specific database + table. If its a cons cell, then the car + produces the standard list and the cdr + produces an enhanced list. + :prompt-regexp regular expression string that matches the prompt issued by the product interpreter. @@ -551,7 +576,6 @@ (defvar sql-indirect-features '(:font-lock :sqli-program :sqli-options :sqli-login)) -;;;###autoload (defcustom sql-connection-alist nil "An alist of connection parameters for interacting with a SQL product. @@ -600,7 +624,6 @@ :version "24.1" :group 'SQL) -;;;###autoload (defcustom sql-product 'ansi "Select the SQL database product used so that buffers can be highlighted properly when you open them." @@ -613,6 +636,7 @@ sql-product-alist)) :group 'SQL :safe 'symbolp) +(defvaralias 'sql-dialect 'sql-product) ;; misc customization of sql.el behaviour @@ -788,7 +812,9 @@ ;; Customization for SQLite -(defcustom sql-sqlite-program "sqlite3" +(defcustom sql-sqlite-program (or (executable-find "sqlite3") + (executable-find "sqlite") + "sqlite") "Command to start SQLite. Starts `sql-interactive-mode' after doing some setup." @@ -801,7 +827,7 @@ :version "20.8" :group 'SQL) -(defcustom sql-sqlite-login-params '((database :file ".*\\.db")) +(defcustom sql-sqlite-login-params '((database :file ".*\\.\\(db\\|sqlite[23]?\\)")) "List of login parameters needed to connect to SQLite." :type 'sql-login-params :version "24.1" @@ -940,7 +966,9 @@ :version "20.8" :group 'SQL) -(defcustom sql-postgres-login-params '(user database server) +(defcustom sql-postgres-login-params `((user :default ,(user-login-name)) + (database :default ,(user-login-name)) + server) "List of login parameters needed to connect to Postgres." :type 'sql-login-params :version "24.1" @@ -1022,11 +1050,14 @@ (defvar sql-server-history nil "History of servers used.") -(defvar sql-port-history nil - "History of ports used.") - ;; Passwords are not kept in a history. +(defvar sql-product-history nil + "History of products used.") + +(defvar sql-connection-history nil + "History of connections used.") + (defvar sql-buffer nil "Current SQLi buffer. @@ -1054,6 +1085,25 @@ Used by `sql-rename-buffer'.") +(defun sql-buffer-live-p (buffer &optional product) + "Returns non-nil if the process associated with buffer is live. + +BUFFER can be a buffer object or a buffer name. The buffer must +be a live buffer, have an running process attached to it, be in +`sql-interactive-mode', and, if PRODUCT is specified, it's +`sql-product' must match." + + (when buffer + (setq buffer (get-buffer buffer)) + (and buffer + (buffer-live-p buffer) + (get-buffer-process buffer) + (comint-check-proc buffer) + (with-current-buffer buffer + (and (derived-mode-p 'sql-interactive-mode) + (or (not product) + (eq product sql-product))))))) + ;; Keymap for sql-interactive-mode. (defvar sql-interactive-mode-map @@ -1069,6 +1119,8 @@ (define-key map (kbd "O") 'sql-magic-go) (define-key map (kbd "o") 'sql-magic-go) (define-key map (kbd ";") 'sql-magic-semicolon) + (define-key map (kbd "C-c C-l a") 'sql-list-all) + (define-key map (kbd "C-c C-l t") 'sql-list-table) map) "Mode map used for `sql-interactive-mode'. Based on `comint-mode-map'.") @@ -1082,6 +1134,8 @@ (define-key map (kbd "C-c C-s") 'sql-send-string) (define-key map (kbd "C-c C-b") 'sql-send-buffer) (define-key map (kbd "C-c C-i") 'sql-product-interactive) + (define-key map (kbd "C-c C-l a") 'sql-list-all) + (define-key map (kbd "C-c C-l t") 'sql-list-table) map) "Mode map used for `sql-mode'.") @@ -1091,15 +1145,14 @@ sql-mode-menu sql-mode-map "Menu for `sql-mode'." `("SQL" - ["Send Paragraph" sql-send-paragraph (and (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] + ["Send Paragraph" sql-send-paragraph (sql-buffer-live-p sql-buffer)] ["Send Region" sql-send-region (and mark-active - (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] - ["Send Buffer" sql-send-buffer (and (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] - ["Send String" sql-send-string (and (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] + (sql-buffer-live-p sql-buffer))] + ["Send Buffer" sql-send-buffer (sql-buffer-live-p sql-buffer)] + ["Send String" sql-send-string (sql-buffer-live-p sql-buffer)] + "--" + ["List all objects" sql-list-all (sql-buffer-live-p sql-buffer)] + ["List table details" sql-list-table (sql-buffer-live-p sql-buffer)] "--" ["Start SQLi session" sql-product-interactive :visible (not sql-connection-alist) @@ -1139,7 +1192,10 @@ "Menu for `sql-interactive-mode'." '("SQL" ["Rename Buffer" sql-rename-buffer t] - ["Save Connection" sql-save-connection (not sql-connection)])) + ["Save Connection" sql-save-connection (not sql-connection)] + "--" + ["List all objects" sql-list-all t] + ["List table details" sql-list-table t])) ;; Abbreviations -- if you want more of them, define them in your ;; ~/.emacs file. Abbrevs have to be enabled in your ~/.emacs, too. @@ -1364,7 +1420,7 @@ ;; Oracle SQL*Plus Commands (cons (concat - "^\\(?:\\(?:" (regexp-opt '( + "^\\s-*\\(?:\\(?:" (regexp-opt '( "@" "@@" "accept" "append" "archive" "attribute" "break" "btitle" "change" "clear" "column" "connect" "copy" "define" "del" "describe" "disconnect" "edit" "execute" "exit" "get" "help" @@ -1403,7 +1459,7 @@ "\\)\\b.*" ) 'font-lock-doc-face) - '("^[ \t]*rem\\(?:ark\\)?.*" . font-lock-comment-face) + '("^\\s-*rem\\(?:ark\\)?\\>.*" . font-lock-comment-face) ;; Oracle Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil @@ -1585,81 +1641,153 @@ (defvar sql-mode-postgres-font-lock-keywords (eval-when-compile (list - ;; Postgres Functions + ;; Postgres psql commands + '("^\\s-*\\\\.*$" . font-lock-doc-face) + + ;; Postgres unreserved words but may have meaning + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "a" +"abs" "absent" "according" "ada" "alias" "allocate" "are" "array_agg" +"asensitive" "atomic" "attribute" "attributes" "avg" "base64" +"bernoulli" "bit_length" "bitvar" "blob" "blocked" "bom" "breadth" "c" +"call" "cardinality" "catalog_name" "ceil" "ceiling" "char_length" +"character_length" "character_set_catalog" "character_set_name" +"character_set_schema" "characters" "checked" "class_origin" "clob" +"cobol" "collation" "collation_catalog" "collation_name" +"collation_schema" "collect" "column_name" "columns" +"command_function" "command_function_code" "completion" "condition" +"condition_number" "connect" "connection_name" "constraint_catalog" +"constraint_name" "constraint_schema" "constructor" "contains" +"control" "convert" "corr" "corresponding" "count" "covar_pop" +"covar_samp" "cube" "cume_dist" "current_default_transform_group" +"current_path" "current_transform_group_for_type" "cursor_name" +"datalink" "datetime_interval_code" "datetime_interval_precision" "db" +"defined" "degree" "dense_rank" "depth" "deref" "derived" "describe" +"descriptor" "destroy" "destructor" "deterministic" "diagnostics" +"disconnect" "dispatch" "dlnewcopy" "dlpreviouscopy" "dlurlcomplete" +"dlurlcompleteonly" "dlurlcompletewrite" "dlurlpath" "dlurlpathonly" +"dlurlpathwrite" "dlurlscheme" "dlurlserver" "dlvalue" "dynamic" +"dynamic_function" "dynamic_function_code" "element" "empty" +"end-exec" "equals" "every" "exception" "exec" "existing" "exp" "file" +"filter" "final" "first_value" "flag" "floor" "fortran" "found" "free" +"fs" "fusion" "g" "general" "generated" "get" "go" "goto" "grouping" +"hex" "hierarchy" "host" "id" "ignore" "implementation" "import" +"indent" "indicator" "infix" "initialize" "instance" "instantiable" +"integrity" "intersection" "iterate" "k" "key_member" "key_type" "lag" +"last_value" "lateral" "lead" "length" "less" "library" "like_regex" +"link" "ln" "locator" "lower" "m" "map" "matched" "max" +"max_cardinality" "member" "merge" "message_length" +"message_octet_length" "message_text" "method" "min" "mod" "modifies" +"modify" "module" "more" "multiset" "mumps" "namespace" "nclob" +"nesting" "new" "nfc" "nfd" "nfkc" "nfkd" "nil" "normalize" +"normalized" "nth_value" "ntile" "nullable" "number" +"occurrences_regex" "octet_length" "octets" "old" "open" "operation" +"ordering" "ordinality" "others" "output" "overriding" "p" "pad" +"parameter" "parameter_mode" "parameter_name" +"parameter_ordinal_position" "parameter_specific_catalog" +"parameter_specific_name" "parameter_specific_schema" "parameters" +"pascal" "passing" "passthrough" "percent_rank" "percentile_cont" +"percentile_disc" "permission" "pli" "position_regex" "postfix" +"power" "prefix" "preorder" "public" "rank" "reads" "recovery" "ref" +"referencing" "regr_avgx" "regr_avgy" "regr_count" "regr_intercept" +"regr_r2" "regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "requiring" +"respect" "restore" "result" "return" "returned_cardinality" +"returned_length" "returned_octet_length" "returned_sqlstate" "rollup" +"routine" "routine_catalog" "routine_name" "routine_schema" +"row_count" "row_number" "scale" "schema_name" "scope" "scope_catalog" +"scope_name" "scope_schema" "section" "selective" "self" "sensitive" +"server_name" "sets" "size" "source" "space" "specific" +"specific_name" "specifictype" "sql" "sqlcode" "sqlerror" +"sqlexception" "sqlstate" "sqlwarning" "sqrt" "state" "static" +"stddev_pop" "stddev_samp" "structure" "style" "subclass_origin" +"sublist" "submultiset" "substring_regex" "sum" "system_user" "t" +"table_name" "tablesample" "terminate" "than" "ties" "timezone_hour" +"timezone_minute" "token" "top_level_count" "transaction_active" +"transactions_committed" "transactions_rolled_back" "transform" +"transforms" "translate" "translate_regex" "translation" +"trigger_catalog" "trigger_name" "trigger_schema" "trim_array" +"uescape" "under" "unlink" "unnamed" "unnest" "untyped" "upper" "uri" +"usage" "user_defined_type_catalog" "user_defined_type_code" +"user_defined_type_name" "user_defined_type_schema" "var_pop" +"var_samp" "varbinary" "variable" "whenever" "width_bucket" "within" +"xmlagg" "xmlbinary" "xmlcast" "xmlcomment" "xmldeclaration" +"xmldocument" "xmlexists" "xmliterate" "xmlnamespaces" "xmlquery" +"xmlschema" "xmltable" "xmltext" "xmlvalidate" +) + + ;; Postgres non-reserved words (sql-font-lock-keywords-builder 'font-lock-builtin-face nil -"abbrev" "abs" "acos" "age" "area" "ascii" "asin" "atab2" "atan" -"atan2" "avg" "bit_length" "both" "broadcast" "btrim" "cbrt" "ceil" -"center" "char_length" "chr" "coalesce" "col_description" "convert" -"cos" "cot" "count" "current_database" "current_date" "current_schema" -"current_schemas" "current_setting" "current_time" "current_timestamp" -"current_user" "currval" "date_part" "date_trunc" "decode" "degrees" -"diameter" "encode" "exp" "extract" "floor" "get_bit" "get_byte" -"has_database_privilege" "has_function_privilege" -"has_language_privilege" "has_schema_privilege" "has_table_privilege" -"height" "host" "initcap" "isclosed" "isfinite" "isopen" "leading" -"length" "ln" "localtime" "localtimestamp" "log" "lower" "lpad" -"ltrim" "masklen" "max" "min" "mod" "netmask" "network" "nextval" -"now" "npoints" "nullif" "obj_description" "octet_length" "overlay" -"pclose" "pg_client_encoding" "pg_function_is_visible" -"pg_get_constraintdef" "pg_get_indexdef" "pg_get_ruledef" -"pg_get_userbyid" "pg_get_viewdef" "pg_opclass_is_visible" -"pg_operator_is_visible" "pg_table_is_visible" "pg_type_is_visible" -"pi" "popen" "position" "pow" "quote_ident" "quote_literal" "radians" -"radius" "random" "repeat" "replace" "round" "rpad" "rtrim" -"session_user" "set_bit" "set_byte" "set_config" "set_masklen" -"setval" "sign" "sin" "split_part" "sqrt" "stddev" "strpos" "substr" -"substring" "sum" "tan" "timeofday" "to_ascii" "to_char" "to_date" -"to_hex" "to_number" "to_timestamp" "trailing" "translate" "trim" -"trunc" "upper" "variance" "version" "width" +"abort" "absolute" "access" "action" "add" "admin" "after" "aggregate" +"also" "alter" "always" "assertion" "assignment" "at" "backward" +"before" "begin" "between" "by" "cache" "called" "cascade" "cascaded" +"catalog" "chain" "characteristics" "checkpoint" "class" "close" +"cluster" "coalesce" "comment" "comments" "commit" "committed" +"configuration" "connection" "constraints" "content" "continue" +"conversion" "copy" "cost" "createdb" "createrole" "createuser" "csv" +"current" "cursor" "cycle" "data" "database" "day" "deallocate" "dec" +"declare" "defaults" "deferred" "definer" "delete" "delimiter" +"delimiters" "dictionary" "disable" "discard" "document" "domain" +"drop" "each" "enable" "encoding" "encrypted" "enum" "escape" +"exclude" "excluding" "exclusive" "execute" "exists" "explain" +"external" "extract" "family" "first" "float" "following" "force" +"forward" "function" "functions" "global" "granted" "greatest" +"handler" "header" "hold" "hour" "identity" "if" "immediate" +"immutable" "implicit" "including" "increment" "index" "indexes" +"inherit" "inherits" "inline" "inout" "input" "insensitive" "insert" +"instead" "invoker" "isolation" "key" "language" "large" "last" +"lc_collate" "lc_ctype" "least" "level" "listen" "load" "local" +"location" "lock" "login" "mapping" "match" "maxvalue" "minute" +"minvalue" "mode" "month" "move" "name" "names" "national" "nchar" +"next" "no" "nocreatedb" "nocreaterole" "nocreateuser" "noinherit" +"nologin" "none" "nosuperuser" "nothing" "notify" "nowait" "nullif" +"nulls" "object" "of" "oids" "operator" "option" "options" "out" +"overlay" "owned" "owner" "parser" "partial" "partition" "password" +"plans" "position" "preceding" "prepare" "prepared" "preserve" "prior" +"privileges" "procedural" "procedure" "quote" "range" "read" +"reassign" "recheck" "recursive" "reindex" "relative" "release" +"rename" "repeatable" "replace" "replica" "reset" "restart" "restrict" +"returns" "revoke" "role" "rollback" "row" "rows" "rule" "savepoint" +"schema" "scroll" "search" "second" "security" "sequence" "sequences" +"serializable" "server" "session" "set" "setof" "share" "show" +"simple" "stable" "standalone" "start" "statement" "statistics" +"stdin" "stdout" "storage" "strict" "strip" "substring" "superuser" +"sysid" "system" "tables" "tablespace" "temp" "template" "temporary" +"transaction" "treat" "trigger" "trim" "truncate" "trusted" "type" +"unbounded" "uncommitted" "unencrypted" "unknown" "unlisten" "until" +"update" "vacuum" "valid" "validator" "value" "values" "version" +"view" "volatile" "whitespace" "work" "wrapper" "write" +"xmlattributes" "xmlconcat" "xmlelement" "xmlforest" "xmlparse" +"xmlpi" "xmlroot" "xmlserialize" "year" "yes" ) + ;; Postgres Reserved (sql-font-lock-keywords-builder 'font-lock-keyword-face nil -"abort" "access" "add" "after" "aggregate" "alignment" "all" "alter" -"analyze" "and" "any" "as" "asc" "assignment" "authorization" -"backward" "basetype" "before" "begin" "between" "binary" "by" "cache" -"called" "cascade" "case" "cast" "characteristics" "check" -"checkpoint" "class" "close" "cluster" "column" "comment" "commit" -"committed" "commutator" "constraint" "constraints" "conversion" -"copy" "create" "createdb" "createuser" "cursor" "cycle" "database" -"deallocate" "declare" "default" "deferrable" "deferred" "definer" -"delete" "delimiter" "desc" "distinct" "do" "domain" "drop" "each" -"element" "else" "encoding" "encrypted" "end" "escape" "except" -"exclusive" "execute" "exists" "explain" "extended" "external" "false" -"fetch" "finalfunc" "for" "force" "foreign" "forward" "freeze" "from" -"full" "function" "grant" "group" "gtcmp" "handler" "hashes" "having" -"immediate" "immutable" "implicit" "in" "increment" "index" "inherits" -"initcond" "initially" "input" "insensitive" "insert" "instead" -"internallength" "intersect" "into" "invoker" "is" "isnull" -"isolation" "join" "key" "language" "leftarg" "level" "like" "limit" -"listen" "load" "local" "location" "lock" "ltcmp" "main" "match" -"maxvalue" "merges" "minvalue" "mode" "move" "natural" "negator" -"next" "nocreatedb" "nocreateuser" "none" "not" "nothing" "notify" -"notnull" "null" "of" "offset" "oids" "on" "only" "operator" "or" -"order" "output" "owner" "partial" "passedbyvalue" "password" "plain" -"prepare" "primary" "prior" "privileges" "procedural" "procedure" -"public" "read" "recheck" "references" "reindex" "relative" "rename" -"reset" "restrict" "returns" "revoke" "rightarg" "rollback" "row" -"rule" "schema" "scroll" "security" "select" "sequence" "serializable" -"session" "set" "sfunc" "share" "show" "similar" "some" "sort1" -"sort2" "stable" "start" "statement" "statistics" "storage" "strict" -"stype" "sysid" "table" "temp" "template" "temporary" "then" "to" -"transaction" "trigger" "true" "truncate" "trusted" "type" -"unencrypted" "union" "unique" "unknown" "unlisten" "until" "update" -"usage" "user" "using" "vacuum" "valid" "validator" "values" -"variable" "verbose" "view" "volatile" "when" "where" "with" "without" -"work" +"all" "analyse" "analyze" "and" "any" "array" "asc" "as" "asymmetric" +"authorization" "binary" "both" "case" "cast" "check" "collate" +"column" "concurrently" "constraint" "create" "cross" +"current_catalog" "current_date" "current_role" "current_schema" +"current_time" "current_timestamp" "current_user" "default" +"deferrable" "desc" "distinct" "do" "else" "end" "except" "false" +"fetch" "foreign" "for" "freeze" "from" "full" "grant" "group" +"having" "ilike" "initially" "inner" "in" "intersect" "into" "isnull" +"is" "join" "leading" "left" "like" "limit" "localtime" +"localtimestamp" "natural" "notnull" "not" "null" "off" "offset" +"only" "on" "order" "or" "outer" "overlaps" "over" "placing" "primary" +"references" "returning" "right" "select" "session_user" "similar" +"some" "symmetric" "table" "then" "to" "trailing" "true" "union" +"unique" "user" "using" "variadic" "verbose" "when" "where" "window" +"with" ) ;; Postgres Data Types (sql-font-lock-keywords-builder 'font-lock-type-face nil -"anyarray" "bigint" "bigserial" "bit" "boolean" "box" "bytea" "char" -"character" "cidr" "circle" "cstring" "date" "decimal" "double" -"float4" "float8" "inet" "int2" "int4" "int8" "integer" "internal" -"interval" "language_handler" "line" "lseg" "macaddr" "money" -"numeric" "oid" "opaque" "path" "point" "polygon" "precision" "real" -"record" "regclass" "regoper" "regoperator" "regproc" "regprocedure" -"regtype" "serial" "serial4" "serial8" "smallint" "text" "time" -"timestamp" "varchar" "varying" "void" "zone" +"bigint" "bigserial" "bit" "bool" "boolean" "box" "bytea" "char" +"character" "cidr" "circle" "date" "decimal" "double" "float4" +"float8" "inet" "int" "int2" "int4" "int8" "integer" "interval" "line" +"lseg" "macaddr" "money" "numeric" "path" "point" "polygon" +"precision" "real" "serial" "serial4" "serial8" "smallint" "text" +"time" "timestamp" "timestamptz" "timetz" "tsquery" "tsvector" +"txid_snapshot" "uuid" "varbit" "varchar" "varying" "without" +"xml" "zone" ))) "Postgres SQL keywords used by font-lock. @@ -1979,6 +2107,9 @@ (defvar sql-mode-sqlite-font-lock-keywords (eval-when-compile (list + ;; SQLite commands + '("^[.].*$" . font-lock-doc-face) + ;; SQLite Keyword (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "abort" "action" "add" "after" "all" "alter" "analyze" "and" "as" @@ -2047,6 +2178,16 @@ ;;; SQL Product support functions +(defun sql-read-product (prompt &optional initial) + "Read a valid SQL product." + (let ((init (or (and initial (symbol-name initial)) "ansi"))) + (intern (completing-read + prompt + (mapcar (lambda (info) (symbol-name (car info))) + sql-product-alist) + nil 'require-match + init 'sql-product-history init)))) + (defun sql-add-product (product display &rest plist) "Add support for a database product in `sql-mode'. @@ -2237,10 +2378,9 @@ (mapcar (lambda (param) (let ((token (or (and (listp param) (car param)) param)) - (type (or (and (listp param) (nth 1 param)) nil)) - (arg (or (and (listp param) (nth 2 param)) nil))) - - (funcall body token type arg))) + (plist (or (and (listp param) (cdr param)) nil))) + + (funcall body token plist))) login-params))) @@ -2260,11 +2400,7 @@ (defun sql-set-product (product) "Set `sql-product' to PRODUCT and enable appropriate highlighting." (interactive - (list (completing-read "SQL product: " - (mapcar (lambda (info) (symbol-name (car info))) - sql-product-alist) - nil 'require-match - (or (and sql-product (symbol-name sql-product)) "ansi")))) + (list (sql-read-product "SQL product: "))) (if (stringp product) (setq product (intern product))) (when (not (assoc product sql-product-alist)) (error "SQL product %s is not supported; treated as ANSI" product) @@ -2404,37 +2540,53 @@ "Read a password using PROMPT. Optional DEFAULT is password to start with." (read-passwd prompt nil default)) -(defun sql-get-login-ext (prompt last-value history-var type arg) +(defun sql-get-login-ext (prompt last-value history-var plist) "Prompt user with extended login parameters. -If TYPE is nil, then the user is simply prompted for a string +If PLIST is nil, then the user is simply prompted for a string value. -If TYPE is `:file', then the user is prompted for a file -name that must match the regexp pattern specified in the ARG -argument. - -If TYPE is `:completion', then the user is prompted for a string -specified by ARG. (ARG is used as the PREDICATE argument to +The property `:default' specifies the default value. If the +`:number' property is non-nil then ask for a number. + +The `:file' property prompts for a file name that must match the +regexp pattern specified in its value. + +The `:completion' property prompts for a string specified by its +value. (The property value is used as the PREDICATE argument to `completing-read'.)" - (cond - ((eq type nil) - (read-from-minibuffer prompt last-value nil nil history-var)) - - ((eq type :file) - (let ((use-dialog-box nil)) + (let* ((default (plist-get plist :default)) + (prompt-def + (if default + (if (string-match "\\(\\):[ \t]*\\'" prompt) + (replace-match (format " (default \"%s\")" default) t t prompt 1) + (replace-regexp-in-string "[ \t]*\\'" + (format " (default \"%s\") " default) + prompt t t)) + prompt)) + (use-dialog-box nil)) + (cond + ((plist-member plist :file) (expand-file-name (read-file-name prompt - (file-name-directory last-value) nil t + (file-name-directory last-value) default t (file-name-nondirectory last-value) - (if arg - `(lambda (f) - (string-match (concat "\\<" ,arg "\\>") - (file-name-nondirectory f))) - nil))))) - - ((eq type :completion) - (completing-read prompt arg nil t last-value history-var)))) + (when (plist-get plist :file) + `(lambda (f) + (string-match + (concat "\\<" ,(plist-get plist :file) "\\>") + (file-name-nondirectory f))))))) + + ((plist-member plist :completion) + (completing-read prompt-def (plist-get plist :completion) nil t + last-value history-var default)) + + ((plist-get plist :number) + (read-number prompt (or default last-value 0))) + + (t + (let ((r (read-from-minibuffer prompt-def last-value nil nil history-var nil))) + (if (string= "" r) (or default "") r)))))) (defun sql-get-login (&rest what) "Get username, password and database from the user. @@ -2453,69 +2605,69 @@ `database'. The members of WHAT are processed in the order in which they are provided. -The tokens for `database' and `server' may also be lists to -control or limit the values that can be supplied. These can be -of the form: - - \(database :file \".+\\\\.EXT\") - \(database :completion FUNCTION) - -The `server' token supports the same forms. +Each token may also be a list with the token in the car and a +plist of options as the cdr. The following properties are +supported: + + :file <filename-regexp> + :completion <list-of-strings-or-function> + :default <default-value> + :number t In order to ask the user for username, password and database, call the function like this: (sql-get-login 'user 'password 'database)." (interactive) - (mapcar - (lambda (w) - (let ((token (or (and (listp w) (car w)) w)) - (type (or (and (listp w) (nth 1 w)) nil)) - (arg (or (and (listp w) (nth 2 w)) nil))) - - (cond - ((eq token 'user) ; user - (setq sql-user - (read-from-minibuffer "User: " sql-user nil nil - 'sql-user-history))) - - ((eq token 'password) ; password - (setq sql-password - (sql-read-passwd "Password: " sql-password))) - - ((eq token 'server) ; server - (setq sql-server - (sql-get-login-ext "Server: " sql-server - 'sql-server-history type arg))) - - ((eq token 'database) ; database - (setq sql-database - (sql-get-login-ext "Database: " sql-database - 'sql-database-history type arg))) - - ((eq token 'port) ; port - (setq sql-port - (read-number "Port: " sql-port)))))) - what)) - -(defun sql-find-sqli-buffer () - "Returns the current default SQLi buffer or nil. -In order to qualify, the SQLi buffer must be alive, -be in `sql-interactive-mode' and have a process." - (let ((default-buffer (default-value 'sql-buffer))) - (if (and (buffer-live-p default-buffer) - (get-buffer-process default-buffer)) - default-buffer - (save-current-buffer - (let ((buflist (buffer-list)) - (found)) - (while (not (or (null buflist) - found)) - (let ((candidate (car buflist))) - (set-buffer candidate) - (if (and (derived-mode-p 'sql-interactive-mode) - (get-buffer-process candidate)) - (setq found candidate)) - (setq buflist (cdr buflist)))) - found))))) + (mapcar + (lambda (w) + (let ((token (or (and (consp w) (car w)) w)) + (plist (or (and (consp w) (cdr w)) nil))) + + (cond + ((eq token 'user) ; user + (setq sql-user + (sql-get-login-ext "User: " sql-user + 'sql-user-history plist))) + + ((eq token 'password) ; password + (setq sql-password + (sql-read-passwd "Password: " sql-password))) + + ((eq token 'server) ; server + (setq sql-server + (sql-get-login-ext "Server: " sql-server + 'sql-server-history plist))) + + ((eq token 'database) ; database + (setq sql-database + (sql-get-login-ext "Database: " sql-database + 'sql-database-history plist))) + + ((eq token 'port) ; port + (setq sql-port + (sql-get-login-ext "Port: " sql-port + nil (append '(:number t) plist))))))) + what)) + +(defun sql-find-sqli-buffer (&optional product) + "Returns the name of the current default SQLi buffer or nil. +In order to qualify, the SQLi buffer must be alive, be in +`sql-interactive-mode' and have a process." + (let ((buf sql-buffer) + (prod (or product sql-product))) + (or + ;; Current sql-buffer, if there is one. + (and (sql-buffer-live-p buf prod) + buf) + ;; Global sql-buffer + (and (setq buf (default-value 'sql-buffer)) + (sql-buffer-live-p buf prod) + buf) + ;; Look thru each buffer + (car (apply 'append + (mapcar (lambda (b) + (and (sql-buffer-live-p b prod) + (list (buffer-name b)))) + (buffer-list))))))) (defun sql-set-sqli-buffer-generally () "Set SQLi buffer for all SQL buffers that have none. @@ -2527,16 +2679,17 @@ (interactive) (save-excursion (let ((buflist (buffer-list)) - (default-sqli-buffer (sql-find-sqli-buffer))) - (setq-default sql-buffer default-sqli-buffer) + (default-buffer (sql-find-sqli-buffer))) + (setq-default sql-buffer default-buffer) (while (not (null buflist)) (let ((candidate (car buflist))) (set-buffer candidate) (if (and (derived-mode-p 'sql-mode) - (not (buffer-live-p sql-buffer))) + (not (sql-buffer-live-p sql-buffer))) (progn - (setq sql-buffer default-sqli-buffer) - (run-hooks 'sql-set-sqli-hook)))) + (setq sql-buffer default-buffer) + (when default-buffer + (run-hooks 'sql-set-sqli-hook))))) (setq buflist (cdr buflist)))))) (defun sql-set-sqli-buffer () @@ -2554,19 +2707,13 @@ (interactive) (let ((default-buffer (sql-find-sqli-buffer))) (if (null default-buffer) - (error "There is no suitable SQLi buffer")) - (let ((new-buffer - (get-buffer - (read-buffer "New SQLi buffer: " default-buffer t)))) - (if (null (get-buffer-process new-buffer)) - (error "Buffer %s has no process" (buffer-name new-buffer))) - (if (null (with-current-buffer new-buffer - (equal major-mode 'sql-interactive-mode))) - (error "Buffer %s is no SQLi buffer" (buffer-name new-buffer))) - (if new-buffer - (progn - (setq sql-buffer new-buffer) - (run-hooks 'sql-set-sqli-hook)))))) + (error "There is no suitable SQLi buffer") + (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t))) + (if (null (sql-buffer-live-p new-buffer)) + (error "Buffer %s is not a working SQLi buffer" new-buffer) + (when new-buffer + (setq sql-buffer new-buffer) + (run-hooks 'sql-set-sqli-hook))))))) (defun sql-show-sqli-buffer () "Show the name of current SQLi buffer. @@ -2574,11 +2721,11 @@ This is the buffer SQL strings are sent to. It is stored in the variable `sql-buffer'. See `sql-help' on how to create such a buffer." (interactive) - (if (null (buffer-live-p sql-buffer)) + (if (null (buffer-live-p (get-buffer sql-buffer))) (message "%s has no SQLi buffer set." (buffer-name (current-buffer))) (if (null (get-buffer-process sql-buffer)) - (message "Buffer %s has no process." (buffer-name sql-buffer)) - (message "Current SQLi buffer is %s." (buffer-name sql-buffer))))) + (message "Buffer %s has no process." sql-buffer) + (message "Current SQLi buffer is %s." sql-buffer)))) (defun sql-make-alternate-buffer-name () "Return a string that can be used to rename a SQLi buffer. @@ -2604,24 +2751,25 @@ (apply 'append nil (sql-for-each-login (sql-get-product-feature sql-product :sqli-login) - (lambda (token type arg) + (lambda (token plist) (cond ((eq token 'user) (unless (string= "" sql-user) (list "/" sql-user))) ((eq token 'port) - (unless (= 0 sql-port) - (list ":" sql-port))) + (unless (or (not (numberp sql-port)) + (= 0 sql-port)) + (list ":" (number-to-string sql-port)))) ((eq token 'server) (unless (string= "" sql-server) (list "." - (if (eq type :file) + (if (plist-member plist :file) (file-name-nondirectory sql-server) sql-server)))) ((eq token 'database) - (when (string= "" sql-database) + (unless (string= "" sql-database) (list "@" - (if (eq type :file) + (if (plist-member plist :file) (file-name-nondirectory sql-database) sql-database)))) @@ -2649,10 +2797,32 @@ ;; Use the name we've got name)))) -(defun sql-rename-buffer () - "Rename a SQLi buffer." - (interactive) - (rename-buffer (format "*SQL: %s*" sql-alternate-buffer-name) t)) +(defun sql-rename-buffer (&optional new-name) + "Rename a SQL interactive buffer. + +Prompts for the new name if command is preceeded by +\\[universal-argument]. If no buffer name is provided, then the +`sql-alternate-buffer-name' is used. + +The actual buffer name set will be \"*SQL: NEW-NAME*\". If +NEW-NAME is empty, then the buffer name will be \"*SQL*\"." + (interactive "P") + + (if (not (derived-mode-p 'sql-interactive-mode)) + (message "Current buffer is not a SQL interactive buffer") + + (setq sql-alternate-buffer-name + (cond + ((stringp new-name) new-name) + ((consp new-name) + (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " + sql-alternate-buffer-name)) + (t sql-alternate-buffer-name))) + + (rename-buffer (if (string= "" sql-alternate-buffer-name) + "*SQL*" + (format "*SQL: %s*" sql-alternate-buffer-name)) + t))) (defun sql-copy-column () "Copy current column to the end of buffer. @@ -2801,7 +2971,7 @@ (let ((comint-input-sender-no-newline nil) (s (replace-regexp-in-string "[[:space:]\n\r]+\\'" "" str))) - (if (buffer-live-p sql-buffer) + (if (sql-buffer-live-p sql-buffer) (progn ;; Ignore the hoping around... (save-excursion @@ -2814,7 +2984,7 @@ (if sql-send-terminator (sql-send-magic-terminator sql-buffer s sql-send-terminator)) - (message "Sent string to buffer %s." (buffer-name sql-buffer)))) + (message "Sent string to buffer %s." sql-buffer))) ;; Display the sql buffer (if sql-pop-to-buffer-after-send-region @@ -2893,6 +3063,171 @@ +;;; Redirect output functions + +(defun sql-redirect (command combuf &optional outbuf save-prior) + "Execute the SQL command and send output to OUTBUF. + +COMBUF must be an active SQL interactive buffer. OUTBUF may be +an existing buffer, or the name of a non-existing buffer. If +omitted the output is sent to a temporary buffer which will be +killed after the command completes. COMMAND should be a string +of commands accepted by the SQLi program." + + (with-current-buffer combuf + (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*"))) + (proc (get-buffer-process (current-buffer))) + (comint-prompt-regexp (sql-get-product-feature sql-product + :prompt-regexp)) + (start nil)) + (with-current-buffer buf + (toggle-read-only -1) + (unless save-prior + (erase-buffer)) + (goto-char (point-max)) + (unless (zerop (buffer-size)) + (insert "\n")) + (setq start (point))) + + ;; Run the command + (message "Executing SQL command...") + (comint-redirect-send-command-to-process command buf proc nil t) + (while (null comint-redirect-completed) + (accept-process-output nil 1)) + (message "Executing SQL command...done") + + ;; Clean up the output results + (with-current-buffer buf + ;; Remove trailing whitespace + (goto-char (point-max)) + (when (looking-back "[ \t\f\n\r]*" start) + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove echo if there was one + (goto-char start) + (when (looking-at (concat "^" (regexp-quote command) "[\\n]")) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char start))))) + +(defun sql-redirect-value (command combuf regexp &optional regexp-groups) + "Execute the SQL command and return part of result. + +COMBUF must be an active SQL interactive buffer. COMMAND should +be a string of commands accepted by the SQLi program. From the +output, the REGEXP is repeatedly matched and the list of +REGEXP-GROUPS submatches is returned. This behaves much like +\\[comint-redirect-results-list-from-process] but instead of +returning a single submatch it returns a list of each submatch +for each match." + + (let ((outbuf " *SQL-Redirect-values*") + (results nil)) + (sql-redirect command combuf outbuf nil) + (with-current-buffer outbuf + (while (re-search-forward regexp nil t) + (push + (cond + ;; no groups-return all of them + ((null regexp-groups) + (let ((i 1) + (r nil)) + (while (match-beginning i) + (push (match-string i) r)) + (nreverse r))) + ;; one group specified + ((numberp regexp-groups) + (match-string regexp-groups)) + ;; list of numbers; return the specified matches only + ((consp regexp-groups) + (mapcar (lambda (c) + (cond + ((numberp c) (match-string c)) + ((stringp c) (match-substitute-replacement c)) + (t (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" c)))) + regexp-groups)) + ;; String is specified; return replacement string + ((stringp regexp-groups) + (match-substitute-replacement regexp-groups)) + (t + (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" + regexp-groups))) + results))) + (nreverse results))) + +(defun sql-execute (sqlbuf outbuf command arg) + "Executes a command in a SQL interacive buffer and captures the output. + +The commands are run in SQLBUF and the output saved in OUTBUF. +COMMAND must be a string, a function or a list of such elements. +Functions are called with SQLBUF, OUTBUF and ARG as parameters; +strings are formatted with ARG and executed. + +If the results are empty the OUTBUF is deleted, otherwise the +buffer is popped into a view window. " + (mapc + (lambda (c) + (cond + ((stringp c) + (sql-redirect (if arg (format c arg) c) sqlbuf outbuf) t) + ((functionp c) + (apply c sqlbuf outbuf arg)) + (t (error "Unknown sql-execute item %s" c)))) + (if (consp command) command (cons command nil))) + + (setq outbuf (get-buffer outbuf)) + (if (zerop (buffer-size outbuf)) + (kill-buffer outbuf) + (let ((one-win (eq (selected-window) + (get-lru-window)))) + (with-current-buffer outbuf + (set-buffer-modified-p nil) + (toggle-read-only 1)) + (view-buffer-other-window outbuf) + (when one-win + (shrink-window-if-larger-than-buffer))))) + +(defun sql-execute-feature (sqlbuf outbuf feature enhanced arg) + "List objects or details in a separate display buffer." + (let (command) + (with-current-buffer sqlbuf + (setq command (sql-get-product-feature sql-product feature))) + (unless command + (error "%s does not support %s" sql-product feature)) + (when (consp command) + (setq command (if enhanced + (cdr command) + (car command)))) + (sql-execute sqlbuf outbuf command arg))) + +(defun sql-read-table-name (prompt) + "Read the name of a database table." + ;; TODO: Fetch table/view names from database and provide completion. + ;; Also implement thing-at-point if the buffer has valid names in it + ;; (i.e. sql-mode, sql-interactive-mode, or sql-list-all buffers) + (read-from-minibuffer prompt)) + +(defun sql-list-all (&optional enhanced) + "List all database objects." + (interactive "P") + (let ((sqlbuf (sql-find-sqli-buffer))) + (unless sqlbuf + (error "No SQL interactive buffer found")) + (sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil))) + +(defun sql-list-table (name &optional enhanced) + "List the details of a database table. " + (interactive + (list (sql-read-table-name "Table name: ") + current-prefix-arg)) + (let ((sqlbuf (sql-find-sqli-buffer))) + (unless sqlbuf + (error "No SQL interactive buffer found")) + (unless name + (error "No table name specified")) + (sql-execute-feature sqlbuf (format "*List %s*" name) + :list-table enhanced name))) + + + ;;; SQL mode -- uses SQL interactive mode ;;;###autoload @@ -3063,7 +3398,7 @@ (setq local-abbrev-table sql-mode-abbrev-table) (setq abbrev-all-caps 1) ;; Exiting the process will call sql-stop. - (set-process-sentinel (get-buffer-process sql-buffer) 'sql-stop) + (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop) ;; Save the connection name (make-local-variable 'sql-connection) ;; Create a usefull name for renaming this buffer later. @@ -3120,6 +3455,14 @@ ;;; Connection handling +(defun sql-read-connection (prompt &optional initial default) + "Read a connection name." + (let ((completion-ignore-case t)) + (completing-read prompt + (mapcar (lambda (c) (car c)) + sql-connection-alist) + nil t initial 'sql-connection-history default))) + ;;;###autoload (defun sql-connect (connection) "Connect to an interactive session using CONNECTION settings. @@ -3133,12 +3476,7 @@ ;; Prompt for the connection from those defined in the alist (interactive (if sql-connection-alist - (list - (let ((completion-ignore-case t)) - (completing-read "Connection: " - (mapcar (lambda (c) (car c)) - sql-connection-alist) - nil t nil nil '(())))) + (list (sql-read-connection "Connection: " nil '(nil))) nil)) ;; Are there connections defined @@ -3172,10 +3510,10 @@ ;; the remaining params (w/o the connection params) (rem-params (sql-for-each-login login-params - (lambda (token type arg) + (lambda (token plist) (unless (member token set-params) - (if (or type arg) - (list token type arg) + (if plist + (cons token plist) token))))) ;; Remember the connection (sql-connection connection)) @@ -3216,7 +3554,7 @@ (append (list name) (sql-for-each-login `(product ,@login) - (lambda (token type arg) + (lambda (token plist) (cond ((eq token 'product) `(sql-product ',sql-product)) ((eq token 'user) `(sql-user ,sql-user)) @@ -3248,74 +3586,80 @@ ;;; Entry functions for different SQL interpreters. ;;;###autoload -(defun sql-product-interactive (&optional product) +(defun sql-product-interactive (&optional product new-name) "Run PRODUCT interpreter as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. If buffer exists and a process is running, just switch to buffer `*SQL*'. +To specify the SQL product, prefix the call with +\\[universal-argument]. To set the buffer name as well, prefix +the call to \\[sql-product-interactive] with +\\[universal-argument] \\[universal-argument]. + \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" (interactive "P") + ;; Handle universal arguments if specified + (when (not (or executing-kbd-macro noninteractive)) + (when (and (consp product) + (not (cdr product)) + (numberp (car product))) + (when (>= (prefix-numeric-value product) 16) + (when (not new-name) + (setq new-name '(4))) + (setq product '(4))))) + + ;; Get the value of product that we need (setq product (cond - ((equal product '(4)) ; Universal arg, prompt for product - (intern (completing-read "SQL product: " - (mapcar (lambda (info) (symbol-name (car info))) - sql-product-alist) - nil 'require-match - (or (and sql-product (symbol-name sql-product)) "ansi")))) ((and product ; Product specified (symbolp product)) product) + ((= (prefix-numeric-value product) 4) ; C-u, prompt for product + (sql-read-product "SQL product: " sql-product)) (t sql-product))) ; Default to sql-product + ;; If we have a product and it has a interactive mode (if product (when (sql-get-product-feature product :sqli-comint-func) - (if (and sql-buffer - (buffer-live-p sql-buffer) - (comint-check-proc sql-buffer)) - (pop-to-buffer sql-buffer) - - ;; Is the current buffer in sql-mode and - ;; there is a buffer local setting of sql-buffer - (let* ((start-buffer - (and (derived-mode-p 'sql-mode) - (current-buffer))) - (start-sql-buffer - (and start-buffer - (let (found) - (dolist (var (buffer-local-variables)) - (and (consp var) - (eq (car var) 'sql-buffer) - (buffer-live-p (cdr var)) - (get-buffer-process (cdr var)) - (setq found (cdr var)))) - found))) - new-sqli-buffer) - - ;; Get credentials. - (apply 'sql-get-login (sql-get-product-feature product :sqli-login)) - - ;; Connect to database. - (message "Login...") - (funcall (sql-get-product-feature product :sqli-comint-func) - product - (sql-get-product-feature product :sqli-options)) - - ;; Set SQLi mode. - (setq sql-interactive-product product - new-sqli-buffer (current-buffer) - sql-buffer new-sqli-buffer) - (sql-interactive-mode) - - ;; Set `sql-buffer' in the start buffer - (when (and start-buffer (not start-sql-buffer)) + ;; If no new name specified, try to pop to an active SQL + ;; interactive for the same product + (let ((buf (sql-find-sqli-buffer product))) + (if (and (not new-name) buf) + (pop-to-buffer buf) + + ;; We have a new name or sql-buffer doesn't exist or match + ;; Start by remembering where we start + (let ((start-buffer (current-buffer)) + new-sqli-buffer) + + ;; Get credentials. + (apply 'sql-get-login (sql-get-product-feature product :sqli-login)) + + ;; Connect to database. + (message "Login...") + (funcall (sql-get-product-feature product :sqli-comint-func) + product + (sql-get-product-feature product :sqli-options)) + + ;; Set SQLi mode. + (setq new-sqli-buffer (current-buffer)) + (let ((sql-interactive-product product)) + (sql-interactive-mode)) + + ;; Set the new buffer name + (when new-name + (sql-rename-buffer new-name)) + + ;; Set `sql-buffer' in the new buffer and the start buffer + (setq sql-buffer (buffer-name new-sqli-buffer)) (with-current-buffer start-buffer - (setq sql-buffer new-sqli-buffer))) - - ;; All done. - (message "Login...done") - (pop-to-buffer sql-buffer)))) + (setq sql-buffer (buffer-name new-sqli-buffer)) + (run-hooks 'sql-set-sqli-hook)) + + ;; All done. + (message "Login...done") + (pop-to-buffer sql-buffer))))) (message "No default SQL product defined. Set `sql-product'."))) (defun sql-comint (product params) @@ -3323,12 +3667,25 @@ PRODUCT is the SQL product. PARAMS is a list of strings which are passed as command line arguments." - (let ((program (sql-get-product-feature product :sqli-program))) + (let ((program (sql-get-product-feature product :sqli-program)) + (buf-name "SQL")) + ;; make sure we can find the program + (unless (executable-find program) + (error "Unable to locate SQL program \'%s\'" program)) + ;; Make sure buffer name is unique + (when (sql-buffer-live-p (format "*%s*" buf-name)) + (setq buf-name (format "SQL-%s" product)) + (when (sql-buffer-live-p (format "*%s*" buf-name)) + (let ((i 1)) + (while (sql-buffer-live-p + (format "*%s*" + (setq buf-name (format "SQL-%s%d" product i)))) + (setq i (1+ i)))))) (set-buffer - (apply 'make-comint "SQL" program nil params)))) + (apply 'make-comint buf-name program nil params)))) ;;;###autoload -(defun sql-oracle () +(defun sql-oracle (&optional buffer) "Run sqlplus by Oracle as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3343,6 +3700,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-oracle]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-oracle]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3351,8 +3713,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'oracle)) + (interactive "P") + (sql-product-interactive 'oracle buffer)) (defun sql-comint-oracle (product options) "Create comint buffer and connect to Oracle." @@ -3375,7 +3737,7 @@ ;;;###autoload -(defun sql-sybase () +(defun sql-sybase (&optional buffer) "Run isql by Sybase as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3390,6 +3752,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-sybase]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-sybase]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3398,8 +3765,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'sybase)) + (interactive "P") + (sql-product-interactive 'sybase buffer)) (defun sql-comint-sybase (product options) "Create comint buffer and connect to Sybase." @@ -3419,7 +3786,7 @@ ;;;###autoload -(defun sql-informix () +(defun sql-informix (&optional buffer) "Run dbaccess by Informix as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3432,6 +3799,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-informix]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-informix]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3440,8 +3812,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'informix)) + (interactive "P") + (sql-product-interactive 'informix buffer)) (defun sql-comint-informix (product options) "Create comint buffer and connect to Informix." @@ -3456,7 +3828,7 @@ ;;;###autoload -(defun sql-sqlite () +(defun sql-sqlite (&optional buffer) "Run sqlite as an inferior process. SQLite is free software. @@ -3473,6 +3845,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-sqlite]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-sqlite]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3481,8 +3858,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'sqlite)) + (interactive "P") + (sql-product-interactive 'sqlite buffer)) (defun sql-comint-sqlite (product options) "Create comint buffer and connect to SQLite." @@ -3498,7 +3875,7 @@ ;;;###autoload -(defun sql-mysql () +(defun sql-mysql (&optional buffer) "Run mysql by TcX as an inferior process. Mysql versions 3.23 and up are free software. @@ -3515,6 +3892,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-mysql]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-mysql]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3523,8 +3905,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'mysql)) + (interactive "P") + (sql-product-interactive 'mysql buffer)) (defun sql-comint-mysql (product options) "Create comint buffer and connect to MySQL." @@ -3535,7 +3917,7 @@ (setq params (append (list sql-database) params))) (if (not (string= "" sql-server)) (setq params (append (list (concat "--host=" sql-server)) params))) - (if (and sql-port (numberp sql-port)) + (if (not (= 0 sql-port)) (setq params (append (list (concat "--port=" (number-to-string sql-port))) params))) (if (not (string= "" sql-password)) (setq params (append (list (concat "--password=" sql-password)) params))) @@ -3547,7 +3929,7 @@ ;;;###autoload -(defun sql-solid () +(defun sql-solid (&optional buffer) "Run solsql by Solid as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3561,6 +3943,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-solid]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-solid]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3569,8 +3956,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'solid)) + (interactive "P") + (sql-product-interactive 'solid buffer)) (defun sql-comint-solid (product options) "Create comint buffer and connect to Solid." @@ -3588,7 +3975,7 @@ ;;;###autoload -(defun sql-ingres () +(defun sql-ingres (&optional buffer) "Run sql by Ingres as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3601,6 +3988,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-ingres]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-ingres]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3609,8 +4001,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'ingres)) + (interactive "P") + (sql-product-interactive 'ingres buffer)) (defun sql-comint-ingres (product options) "Create comint buffer and connect to Ingres." @@ -3624,7 +4016,7 @@ ;;;###autoload -(defun sql-ms () +(defun sql-ms (&optional buffer) "Run osql by Microsoft as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3639,6 +4031,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-ms]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-ms]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3647,8 +4044,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'ms)) + (interactive "P") + (sql-product-interactive 'ms buffer)) (defun sql-comint-ms (product options) "Create comint buffer and connect to Microsoft SQL Server." @@ -3675,7 +4072,7 @@ ;;;###autoload -(defun sql-postgres () +(defun sql-postgres (&optional buffer) "Run psql by Postgres as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3690,6 +4087,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-postgres]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-postgres]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3703,8 +4105,8 @@ '(comint-strip-ctrl-m))) \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'postgres)) + (interactive "P") + (sql-product-interactive 'postgres buffer)) (defun sql-comint-postgres (product options) "Create comint buffer and connect to Postgres." @@ -3720,12 +4122,14 @@ (setq params (append (list "-h" sql-server) params))) (if (not (string= "" sql-user)) (setq params (append (list "-U" sql-user) params))) + (if (not (= 0 sql-port)) + (setq params (append (list "-p" sql-port) params))) (sql-comint product params))) ;;;###autoload -(defun sql-interbase () +(defun sql-interbase (&optional buffer) "Run isql by Interbase as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3739,6 +4143,11 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-interbase]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-interbase]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3747,8 +4156,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'interbase)) + (interactive "P") + (sql-product-interactive 'interbase buffer)) (defun sql-comint-interbase (product options) "Create comint buffer and connect to Interbase." @@ -3766,7 +4175,7 @@ ;;;###autoload -(defun sql-db2 () +(defun sql-db2 (&optional buffer) "Run db2 by IBM as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3784,6 +4193,11 @@ `comint-input-sender' back to `comint-simple-send' by writing an after advice. See the elisp manual for more information. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-db2]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-db2]. You can also specify this with \\[set-buffer-process-coding-system] @@ -3792,8 +4206,8 @@ `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'db2)) + (interactive "P") + (sql-product-interactive 'db2 buffer)) (defun sql-comint-db2 (product options) "Create comint buffer and connect to DB2." @@ -3801,11 +4215,9 @@ ;; make-comint. (sql-comint product options) ) -;; ;; Properly escape newlines when DB2 is interactive. -;; (setq comint-input-sender 'sql-escape-newlines-and-send)) ;;;###autoload -(defun sql-linter () +(defun sql-linter (&optional buffer) "Run inl by RELEX as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -3827,9 +4239,14 @@ The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-linter]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'linter)) + (interactive "P") + (sql-product-interactive 'linter buffer)) (defun sql-comint-linter (product options) "Create comint buffer and connect to Linter."
--- a/lisp/progmodes/tcl.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/tcl.el Wed Sep 22 15:46:51 2010 +0900 @@ -411,9 +411,10 @@ `tcl-typeword-list', and `tcl-keyword-list' by the function `tcl-set-font-lock-keywords'.") -(defvar tcl-font-lock-syntactic-keywords - ;; Mark the few `#' that are not comment-markers. - '(("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) +(defconst tcl-syntax-propertize-function + (syntax-propertize-rules + ;; Mark the few `#' that are not comment-markers. + ("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) "Syntactic keywords for `tcl-mode'.") ;; FIXME need some way to recognize variables because array refs look @@ -593,9 +594,9 @@ (set (make-local-variable 'outline-level) 'tcl-outline-level) (set (make-local-variable 'font-lock-defaults) - '(tcl-font-lock-keywords nil nil nil beginning-of-defun - (font-lock-syntactic-keywords . tcl-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + '(tcl-font-lock-keywords nil nil nil beginning-of-defun)) + (set (make-local-variable 'syntax-propertize-function) + tcl-syntax-propertize-function) (set (make-local-variable 'imenu-generic-expression) tcl-imenu-generic-expression)
--- a/lisp/progmodes/vhdl-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/progmodes/vhdl-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -4693,8 +4693,15 @@ (set (make-local-variable 'font-lock-defaults) (list '(nil vhdl-font-lock-keywords) nil - (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line - '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords))) + (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line)) + (if (eval-when-compile (fboundp 'syntax-propertize-rules)) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules + ;; Mark single quotes as having string quote syntax in + ;; 'c' instances. + ("\\(\'\\).\\(\'\\)" (1 "\"'") (2 "\"'")))) + (set (make-local-variable 'font-lock-syntactic-keywords) + vhdl-font-lock-syntactic-keywords)) (unless vhdl-emacs-21 (set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode) (set (make-local-variable 'lazy-lock-defer-contextually) nil) @@ -12914,10 +12921,9 @@ "Re-initialize fontification and fontify buffer." (interactive) (setq font-lock-defaults - (list - 'vhdl-font-lock-keywords nil - (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line - '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords))) + `(vhdl-font-lock-keywords + nil ,(not vhdl-highlight-case-sensitive) ((?\_ . "w")) + beginning-of-line)) (when (fboundp 'font-lock-unset-defaults) (font-lock-unset-defaults)) ; not implemented in XEmacs (font-lock-set-defaults)
--- a/lisp/repeat.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/repeat.el Wed Sep 22 15:46:51 2010 +0900 @@ -335,7 +335,12 @@ (setq real-last-command 'repeat) (setq repeat-undo-count 1) (unwind-protect - (while (eq (read-event) repeat-repeat-char) + (while (let ((evt (read-event))) ;FIXME: read-key maybe? + ;; For clicks, we need to strip the meta-data to + ;; check the underlying event name. + (eq (or (car-safe evt) evt) + (or (car-safe repeat-repeat-char) + repeat-repeat-char))) (repeat repeat-arg)) ;; Make sure `repeat-undo-count' is reset. (setq repeat-undo-count nil))
--- a/lisp/simple.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/simple.el Wed Sep 22 15:46:51 2010 +0900 @@ -4343,7 +4343,7 @@ (or (and (= (vertical-motion (cons (or goal-column (if (consp temporary-goal-column) - (truncate (car temporary-goal-column)) + (car temporary-goal-column) temporary-goal-column)) arg)) arg) @@ -5525,9 +5525,10 @@ ;; backward-sexp skips backward over prefix chars, ;; so move back to the matching paren. (while (and (< (point) (1- oldpos)) - (let ((code (car (syntax-after (point))))) - (or (eq (logand 65536 code) 6) - (eq (logand 1048576 code) 1048576)))) + (let ((code (syntax-after (point)))) + (or (eq (syntax-class code) 6) + (eq (logand 1048576 (car code)) + 1048576)))) (forward-char 1)) (point)) (error nil)))))) @@ -5541,6 +5542,7 @@ (if (minibufferp) (minibuffer-message " [Unmatched parenthesis]") (message "Unmatched parenthesis")))) + ((not blinkpos) nil) ((pos-visible-in-window-p blinkpos) ;; Matching open within window, temporarily move to blinkpos but only ;; if `blink-matching-paren-on-screen' is non-nil.
--- a/lisp/subr.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/subr.el Wed Sep 22 15:46:51 2010 +0900 @@ -239,7 +239,7 @@ for the sake of consistency." (while t (signal 'error (list (apply 'format args))))) -(set-advertised-calling-convention 'error '(string &rest args)) +(set-advertised-calling-convention 'error '(string &rest args) "23.1") ;; We put this here instead of in frame.el so that it's defined even on ;; systems where frame.el isn't loaded. @@ -1039,9 +1039,10 @@ (make-obsolete 'make-variable-frame-local "explicitly check for a frame-parameter instead." "22.2") (make-obsolete 'interactive-p 'called-interactively-p "23.2") -(set-advertised-calling-convention 'called-interactively-p '(kind)) +(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1") (set-advertised-calling-convention - 'all-completions '(string collection &optional predicate)) + 'all-completions '(string collection &optional predicate) "23.1") +(set-advertised-calling-convention 'unintern '(name obarray) "23.3") ;;;; Obsolescence declarations for variables, and aliases. @@ -2064,7 +2065,7 @@ (setq read (cons t read))) (push read unread-command-events) nil)))))) -(set-advertised-calling-convention 'sit-for '(seconds &optional nodisp)) +(set-advertised-calling-convention 'sit-for '(seconds &optional nodisp) "22.1") ;;; Atomic change groups. @@ -2592,7 +2593,7 @@ (start-process name buffer shell-file-name shell-command-switch (mapconcat 'identity args " "))) (set-advertised-calling-convention 'start-process-shell-command - '(name buffer command)) + '(name buffer command) "23.1") (defun start-file-process-shell-command (name buffer &rest args) "Start a program in a subprocess. Return the process object for it. @@ -2603,7 +2604,7 @@ (if (file-remote-p default-directory) "-c" shell-command-switch) (mapconcat 'identity args " "))) (set-advertised-calling-convention 'start-file-process-shell-command - '(name buffer command)) + '(name buffer command) "23.1") (defun call-process-shell-command (command &optional infile buffer display &rest args) @@ -3358,6 +3359,56 @@ (overlay-put ol2 'evaporate t) (overlay-put ol2 'text-clones dups))) +;;;; Misc functions moved over from the C side. + +(defun y-or-n-p (prompt) + "Ask user a \"y or n\" question. Return t if answer is \"y\". +The argument PROMPT is the string to display to ask the question. +It should end in a space; `y-or-n-p' adds `(y or n) ' to it. +No confirmation of the answer is requested; a single character is enough. +Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses +the bindings in `query-replace-map'; see the documentation of that variable +for more information. In this case, the useful bindings are `act', `skip', +`recenter', and `quit'.\) + +Under a windowing system a dialog box will be used if `last-nonmenu-event' +is nil and `use-dialog-box' is non-nil." + ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state + ;; where all the keys were unbound (i.e. it somehow got triggered + ;; within read-key, apparently). I had to kill it. + (let ((answer 'recenter)) + (if (and (display-popup-menus-p) + (listp last-nonmenu-event) + use-dialog-box) + (setq answer + (x-popup-dialog t `(,prompt ("yes" . act) ("No" . skip)))) + (setq prompt (concat prompt + (if (eq ?\s (aref prompt (1- (length prompt)))) + "" " ") + "(y or n) ")) + (while + (let* ((key + (let ((cursor-in-echo-area t)) + (when minibuffer-auto-raise + (raise-frame (window-frame (minibuffer-window)))) + (read-key (propertize (if (eq answer 'recenter) + prompt + (concat "Please answer y or n. " + prompt)) + 'face 'minibuffer-prompt))))) + (setq answer (lookup-key query-replace-map (vector key) t)) + (cond + ((memq answer '(skip act)) nil) + ((eq answer 'recenter) (recenter) t) + ((memq answer '(exit-prefix quit)) (signal 'quit nil) t) + (t t))) + (ding) + (discard-input))) + (let ((ret (eq answer 'act))) + (unless noninteractive + (message "%s %s" prompt (if ret "y" "n"))) + ret))) + ;;;; Mail user agents. ;; Here we include just enough for other packages to be able
--- a/lisp/term/x-win.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/term/x-win.el Wed Sep 22 15:46:51 2010 +0900 @@ -1344,6 +1344,9 @@ (or clip-text primary-text) ))) +(define-obsolete-function-alias 'x-cut-buffer-or-selection-value + 'x-selection-value "24.1") + ;; Arrange for the kill and yank functions to set and check the clipboard. (setq interprogram-cut-function 'x-select-text) (setq interprogram-paste-function 'x-selection-value)
--- a/lisp/textmodes/bibtex.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/bibtex.el Wed Sep 22 15:46:51 2010 +0900 @@ -3027,12 +3027,14 @@ ;; brace-delimited ones ) nil - (font-lock-syntactic-keywords . bibtex-font-lock-syntactic-keywords) (font-lock-extra-managed-props . (category)) (font-lock-mark-block-function . (lambda () (set-mark (bibtex-end-of-entry)) (bibtex-beginning-of-entry))))) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-via-font-lock + bibtex-font-lock-syntactic-keywords)) (setq imenu-generic-expression (list (list nil bibtex-entry-head bibtex-key-in-head)) imenu-case-fold-search t)
--- a/lisp/textmodes/ispell.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/ispell.el Wed Sep 22 15:46:51 2010 +0900 @@ -770,8 +770,8 @@ -;;; The version must be 3.1 or greater for this version of ispell.el -;;; There is an incompatibility between version 3.1.12 and lower versions. +;; The version must be 3.1 or greater for this version of ispell.el +;; There is an incompatibility between version 3.1.12 and lower versions. (defconst ispell-required-version '(3 1 12) "Ispell versions with which this version of ispell.el is known to work.") (defvar ispell-offset -1 @@ -1106,7 +1106,7 @@ (defun ispell-valid-dictionary-list () - "Returns a list of valid dictionaries. + "Return a list of valid dictionaries. The variable `ispell-library-directory' defines the library location." ;; Initialize variables and dictionaries alists for desired spellchecker. ;; Make sure ispell.el is loaded to avoid some autoload loops in XEmacs @@ -1116,26 +1116,24 @@ (let ((dicts (append ispell-local-dictionary-alist ispell-dictionary-alist)) (dict-list (cons "default" nil)) - name load-dict) + name dict-bname) (dolist (dict dicts) (setq name (car dict) - load-dict (car (cdr (member "-d" (nth 5 dict))))) + dict-bname (or (car (cdr (member "-d" (nth 5 dict)))) + name)) ;; Include if the dictionary is in the library, or dir not defined. (if (and name - ;; include all dictionaries if lib directory not known. ;; For Aspell, we already know which dictionaries exist. (or ispell-really-aspell + ;; Include all dictionaries if lib directory not known. + ;; Same for Hunspell, where ispell-library-directory is nil. (not ispell-library-directory) (file-exists-p (concat ispell-library-directory - "/" name ".hash")) - (file-exists-p (concat ispell-library-directory "/" name ".has")) - (and load-dict - (or (file-exists-p (concat ispell-library-directory - "/" load-dict ".hash")) - (file-exists-p (concat ispell-library-directory - "/" load-dict ".has")))))) - (setq dict-list (cons name dict-list)))) + "/" dict-bname ".hash")) + (file-exists-p (concat ispell-library-directory + "/" dict-bname ".has")))) + (push name dict-list))) dict-list)) ;;; define commands in menu in opposite order you want them to appear. @@ -1271,9 +1269,6 @@ ;;; ********************************************************************** - -;;; This variable contains the current dictionary being used if the ispell -;;; process is running. (defvar ispell-current-dictionary nil "The name of the current dictionary, or nil for the default. This is passed to the ispell process using the `-d' switch and is @@ -1298,6 +1293,7 @@ ;; Return a string decoded from Nth element of the current dictionary. (defun ispell-get-decoded-string (n) + "Get the decoded string in slot N of the descriptor of the current dict." (let* ((slot (or (assoc ispell-current-dictionary ispell-local-dictionary-alist) (assoc ispell-current-dictionary ispell-dictionary-alist) @@ -2153,7 +2149,7 @@ (if (and ispell-use-framepop-p (fboundp 'framepop-display-buffer)) (progn (framepop-display-buffer (get-buffer ispell-choices-buffer)) -;;; (get-buffer-window ispell-choices-buffer t) + ;; (get-buffer-window ispell-choices-buffer t) (select-window (previous-window))) ; *Choices* window ;; standard selection by splitting a small buffer out of this window. (let ((choices-window (get-buffer-window ispell-choices-buffer))) @@ -2548,18 +2544,18 @@ (setq count (string-to-number output) ; get number of misses. output (substring output (1+ (string-match " " output 1))))) (setq offset (string-to-number output)) - (if (eq type ?#) ; No miss or guess list. - (setq output nil) - (setq output (substring output (1+ (string-match " " output 1))))) + (setq output (if (eq type ?#) ; No miss or guess list. + nil + (substring output (1+ (string-match " " output 1))))) (while output (let ((end (string-match ", \\|\\($\\)" output))) ; end of miss/guess. (setq cur-count (1+ cur-count)) (if (> cur-count count) - (setq guess-list (cons (substring output 0 end) guess-list)) - (setq miss-list (cons (substring output 0 end) miss-list))) - (if (match-end 1) ; True only when at end of line. - (setq output nil) ; no more misses or guesses - (setq output (substring output (+ end 2)))))) + (push (substring output 0 end) guess-list) + (push (substring output 0 end) miss-list)) + (setq output (if (match-end 1) ; True only when at end of line. + nil ; No more misses or guesses. + (substring output (+ end 2)))))) ;; return results. Accept word if it was already accepted. ;; adjust offset. (if (member original-word accept-list) @@ -2676,24 +2672,27 @@ ispell-filter-continue nil ispell-process-directory default-directory) - ;; Kill ispell process when killing its associated buffer if using Ispell - ;; per-directory personal dictionaries. (unless (equal ispell-process-directory (expand-file-name "~/")) - (with-current-buffer - (if (and (window-minibuffer-p) - (fboundp 'minibuffer-selected-window)) ;; E.g. XEmacs. - ;; When spellchecking minibuffer contents, assign ispell - ;; process to parent buffer if known (not known for XEmacs). - ;; Use (buffer-name) otherwise. + ;; At this point, `ispell-process-directory' will be "~/" unless using + ;; Ispell with directory-specific dicts and not in XEmacs minibuffer. + ;; If not, kill ispell process when killing buffer. It may be in a + ;; removable device that would otherwise become un-mountable. + (with-current-buffer + (if (and (window-minibuffer-p) ;; In minibuffer + (fboundp 'minibuffer-selected-window)) ;; Not XEmacs. + ;; In this case kill ispell only when parent buffer is killed + ;; to avoid over and over ispell kill. (window-buffer (minibuffer-selected-window)) - (current-buffer)) - (add-hook 'kill-buffer-hook (lambda () (ispell-kill-ispell t)) - nil 'local))) + (current-buffer)) + ;; 'local does not automatically make hook buffer-local in XEmacs. + (if (featurep 'xemacs) + (make-local-hook 'kill-buffer-hook)) + (add-hook 'kill-buffer-hook + (lambda () (ispell-kill-ispell t)) nil 'local))) (if ispell-async-processp (set-process-filter ispell-process 'ispell-filter)) - ;; protect against bogus binding of `enable-multibyte-characters' in - ;; XEmacs. + ;; Protect against XEmacs bogus binding of `enable-multibyte-characters'. (if (and (or (featurep 'xemacs) (and (boundp 'enable-multibyte-characters) enable-multibyte-characters)) @@ -2729,7 +2728,9 @@ (if extended-char-mode ; ~ extended character mode (ispell-send-string (concat extended-char-mode "\n")))) (if ispell-async-processp - (set-process-query-on-exit-flag ispell-process nil))))) + (if (fboundp 'set-process-query-on-exit-flag) ;; not XEmacs + (set-process-query-on-exit-flag ispell-process nil) + (process-kill-without-query ispell-process)))))) ;;;###autoload (defun ispell-kill-ispell (&optional no-error) @@ -2815,7 +2816,11 @@ (setq ispell-current-dictionary dict ispell-current-personal-dictionary pdict)))) -;;; Spelling of comments are checked when ispell-check-comments is non-nil. +;; Avoid error messages when compiling for these dynamic variables. +(defvar ispell-start) +(defvar ispell-end) + +;; Spelling of comments are checked when ispell-check-comments is non-nil. ;;;###autoload (defun ispell-region (reg-start reg-end &optional recheckp shift) @@ -2846,8 +2851,7 @@ (message "searching for regions to skip")) (if (re-search-forward (ispell-begin-skip-region-regexp) reg-end t) (progn - (setq key (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) + (setq key (match-string-no-properties 0)) (set-marker skip-region-start (- (point) (length key))) (goto-char reg-start))) (let (message-log-max) @@ -2893,18 +2897,20 @@ (if (marker-position skip-region-start) (min skip-region-start ispell-region-end) (marker-position ispell-region-end)))) - (let* ((start (point)) - (end (save-excursion (end-of-line) (min (point) reg-end))) - (string (ispell-get-line start end in-comment))) + (let* ((ispell-start (point)) + (ispell-end (save-excursion + (end-of-line) (min (point) reg-end))) + (string (ispell-get-line + ispell-start ispell-end in-comment))) (if in-comment ; account for comment chars added - (setq start (- start (length in-comment)) + (setq ispell-start (- ispell-start (length in-comment)) in-comment nil)) - (setq end (point)) ; "end" tracks region retrieved. + (setq ispell-end (point)) ; "end" tracks region retrieved. (if string ; there is something to spell check! ;; (special start end) (setq shift (ispell-process-line string (and recheckp shift)))) - (goto-char end))))) + (goto-char ispell-end))))) (if ispell-quit nil (or shift 0))) @@ -2941,42 +2947,30 @@ "Return a regexp of the search keys for region skipping. Includes `ispell-skip-region-alist' plus tex, tib, html, and comment keys. Must call after `ispell-buffer-local-parsing' due to dependence on mode." - ;; start with regions generic to all buffers - (let ((skip-regexp (ispell-begin-skip-region ispell-skip-region-alist))) - ;; Comments - (if (and (null ispell-check-comments) comment-start) - (setq skip-regexp (concat (regexp-quote comment-start) "\\|" - skip-regexp))) - (if (and (eq 'exclusive ispell-check-comments) comment-start) - ;; search from end of current comment to start of next comment. - (setq skip-regexp (concat (if (string= "" comment-end) "^" - (regexp-quote comment-end)) - "\\|" skip-regexp))) - ;; tib - (if ispell-skip-tib - (setq skip-regexp (concat ispell-tib-ref-beginning "\\|" skip-regexp))) - ;; html stuff - (if ispell-skip-html - (setq skip-regexp (concat - (ispell-begin-skip-region ispell-html-skip-alists) - "\\|" - skip-regexp))) - ;; tex - (if (eq ispell-parser 'tex) - (setq skip-regexp (concat (ispell-begin-tex-skip-regexp) "\\|" - skip-regexp))) - ;; messages - (if (and ispell-checking-message - (not (eq t ispell-checking-message))) - (setq skip-regexp (concat - (mapconcat (lambda (lst) (car lst)) - ispell-checking-message - "\\|") - "\\|" - skip-regexp))) - - ;; return new regexp - skip-regexp)) + (mapconcat + 'identity + (delq nil + (list + ;; messages + (if (and ispell-checking-message + (not (eq t ispell-checking-message))) + (mapconcat #'car ispell-checking-message "\\|")) + ;; tex + (if (eq ispell-parser 'tex) + (ispell-begin-tex-skip-regexp)) + ;; html stuff + (if ispell-skip-html + (ispell-begin-skip-region ispell-html-skip-alists)) + ;; tib + (if ispell-skip-tib ispell-tib-ref-beginning) + ;; Comments + (if (and (eq 'exclusive ispell-check-comments) comment-start) + ;; search from end of current comment to start of next comment. + (if (string= "" comment-end) "^" (regexp-quote comment-end))) + (if (and (null ispell-check-comments) comment-start) + (regexp-quote comment-start)) + (ispell-begin-skip-region ispell-skip-region-alist))) + "\\|")) (defun ispell-begin-skip-region (skip-alist) @@ -3148,17 +3142,13 @@ (point) (+ (point) len)) coding))))) -;; Avoid error messages when compiling for these dynamic variables. -;; FIXME: dynamically scoped vars should have an "ispell-" prefix. -(defvar start) -(defvar end) - (defun ispell-process-line (string shift) "Send STRING, a line of text, to ispell and processes the result. This will modify the buffer for spelling errors. -Requires variables START and END to be defined in its lexical scope. +Requires variables ISPELL-START and ISPELL-END to be defined in its +dynamic scope. Returns the sum SHIFT due to changes in word replacements." - ;;(declare special start end) + ;;(declare special ispell-start ispell-end) (let (poss accept-list) (if (not (numberp shift)) (setq shift 0)) @@ -3181,10 +3171,10 @@ ;; Markers can move with highlighting! This destroys ;; end of region markers line-end and ispell-region-end (let ((word-start - (copy-marker (+ start ispell-offset (car (cdr poss))))) + (copy-marker (+ ispell-start ispell-offset (car (cdr poss))))) (word-len (length (car poss))) - (line-end (copy-marker end)) - (line-start (copy-marker start)) + (line-end (copy-marker ispell-end)) + (line-start (copy-marker ispell-start)) recheck-region replace) (goto-char word-start) ;; Adjust the horizontal scroll & point @@ -3291,11 +3281,12 @@ (file-name-nondirectory ispell-program-name) (or ispell-current-dictionary "default")))) (sit-for 0) - (setq start (marker-position line-start) - end (marker-position line-end)) + (setq ispell-start (marker-position line-start) + ispell-end (marker-position line-end)) ;; Adjust markers when end of region lost from highlighting. - (if (and (not recheck-region) (< end (+ word-start word-len))) - (setq end (+ word-start word-len))) + (if (and (not recheck-region) + (< ispell-end (+ word-start word-len))) + (setq ispell-end (+ word-start word-len))) (if (= word-start ispell-region-end) (set-marker ispell-region-end (+ word-start word-len))) ;; going out of scope - unneeded @@ -3453,15 +3444,6 @@ ;;; Ispell Minor Mode ;;; ********************************************************************** -(defvar ispell-minor-mode nil - "Non-nil if Ispell minor mode is enabled.") -;; Variable indicating that ispell minor mode is active. -(make-variable-buffer-local 'ispell-minor-mode) - -(or (assq 'ispell-minor-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(ispell-minor-mode " Spell") minor-mode-alist))) - (defvar ispell-minor-keymap (let ((map (make-sparse-keymap))) (define-key map " " 'ispell-minor-check) @@ -3469,14 +3451,8 @@ map) "Keymap used for Ispell minor mode.") -(or (not (boundp 'minor-mode-map-alist)) - (assoc 'ispell-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'ispell-minor-mode ispell-minor-keymap) - minor-mode-map-alist))) - ;;;###autoload -(defun ispell-minor-mode (&optional arg) +(define-minor-mode ispell-minor-mode "Toggle Ispell minor mode. With prefix argument ARG, turn Ispell minor mode on if ARG is positive, otherwise turn it off. @@ -3486,11 +3462,7 @@ All the buffer-local variables and dictionaries are ignored -- to read them into the running ispell process, type \\[ispell-word] SPC." - (interactive "P") - (setq ispell-minor-mode - (not (or (and (null arg) ispell-minor-mode) - (<= (prefix-numeric-value arg) 0)))) - (force-mode-line-update)) + nil " Spell" ispell-minor-keymap) (defun ispell-minor-check () "Check previous word then continue with the normal binding of this key. @@ -3756,15 +3728,14 @@ (goto-char (point-min)) ;; Select type or skip checking if this is a non-multipart message ;; Point moved to end of buffer if region is encoded. - (if (and mimep (not boundary)) - (let (skip-regexp) ; protect from `ispell-mime-skip-part' + (when (and mimep (not boundary)) (goto-char (point-min)) (re-search-forward "Content-[^ \t]*:" end-of-headers t) (forward-line -1) ; following fn starts one line above (ispell-mime-skip-part nil) ;; if message-text-end region, limit may be less than point. (if (> (point) limit) - (set-marker limit (point))))) + (set-marker limit (point)))) (goto-char (max end-of-headers (point))) (forward-line 1) (setq case-fold-search old-case-fold-search) @@ -3847,7 +3818,7 @@ (sit-for 2)))))))) -;;; Can kill the current ispell process +;; Can kill the current ispell process (defun ispell-buffer-local-dict (&optional no-reload) "Initializes local dictionary and local personal dictionary. @@ -3920,16 +3891,14 @@ (setq ispell-buffer-local-name (buffer-name))) (save-excursion (goto-char (point-min)) - (let ((old-case-fold-search case-fold-search) - line-okay search done found) + (let (line-okay search done found) (while (not done) - (setq case-fold-search nil - search (search-forward ispell-words-keyword nil 'move) + (let ((case-fold-search nil)) + (setq search (search-forward ispell-words-keyword nil 'move) found (or found search) line-okay (< (+ (length word) 1 ; 1 for space after word.. (progn (end-of-line) (current-column))) - 80) - case-fold-search old-case-fold-search) + fill-column))) (if (or (and search line-okay) (null search)) (progn @@ -3938,7 +3907,13 @@ (progn (open-line 1) (unless found (newline)) - (insert (concat comment-start " " ispell-words-keyword)) + (insert (if (fboundp 'comment-padright) + ;; Try and use the proper comment marker, + ;; e.g. ";;" rather than ";". + (comment-padright comment-start + (comment-add nil)) + comment-start) + " " ispell-words-keyword) (if (> (length comment-end) 0) (save-excursion (newline)
--- a/lisp/textmodes/nroff-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/nroff-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -311,10 +311,16 @@ "Run man on this file." (interactive) (require 'man) - (let* ((file (buffer-file-name))) - (if file - (Man-getpage-in-background file) - (error "No associated file for the current buffer")))) + (let* ((file (buffer-file-name)) + (viewbuf (get-buffer (concat "*Man " file "*")))) + (unless file + (error "Buffer is not associated with any file")) + (and (buffer-modified-p) + (y-or-n-p (format "Save buffer %s first? " (buffer-name))) + (save-buffer)) + (if viewbuf + (kill-buffer viewbuf)) + (Man-getpage-in-background file))) ;; Old names that were not namespace clean. (define-obsolete-function-alias 'count-text-lines 'nroff-count-text-lines "22.1")
--- a/lisp/textmodes/reftex-parse.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/reftex-parse.el Wed Sep 22 15:46:51 2010 +0900 @@ -385,7 +385,7 @@ (defun reftex-section-info (file) ;; Return a section entry for the current match. - ;; Carefull: This function expects the match-data to be still in place! + ;; Careful: This function expects the match-data to be still in place! (let* ((marker (set-marker (make-marker) (1- (match-beginning 3)))) (macro (reftex-match-string 3)) (prefix (save-match-data @@ -775,16 +775,18 @@ pos cmd-list cmd cnt cnt-opt entry) (save-restriction (save-excursion - (narrow-to-region (max 1 bound) (point-max)) + (narrow-to-region (max (point-min) bound) (point-max)) ;; move back out of the current parenthesis (while (condition-case nil - (progn (up-list -1) t) + (let ((forward-sexp-function nil)) + (up-list -1) t) (error nil)) (setq cnt 1 cnt-opt 0) ;; move back over any touching sexps (while (and (reftex-move-to-previous-arg bound) (condition-case nil - (progn (backward-sexp) t) + (let ((forward-sexp-function nil)) + (backward-sexp) t) (error nil))) (if (eq (following-char) ?\[) (incf cnt-opt)) (incf cnt)) @@ -965,15 +967,14 @@ (if (re-search-forward "\\\\end{" nil t) (match-beginning 0) (point-max)))))) - ((or (= (preceding-char) ?\{) - (= (preceding-char) ?\[)) + ((memq (preceding-char) '(?\{ ?\[)) ;; Inside a list - get only the list. (buffer-substring-no-properties (point) (min (+ (point) 150) (point-max) (condition-case nil - (progn + (let ((forward-sexp-function nil)) ;Unneeded fanciness. (up-list 1) (1- (point))) (error (point-max))))))
--- a/lisp/textmodes/reftex.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/reftex.el Wed Sep 22 15:46:51 2010 +0900 @@ -599,7 +599,6 @@ (defvar font-lock-mode) (defvar font-lock-keywords) (defvar font-lock-fontify-region-function) -(defvar font-lock-syntactic-keywords) ;;; ========================================================================= ;;;
--- a/lisp/textmodes/sgml-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/sgml-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -293,11 +293,12 @@ (defvar sgml-font-lock-keywords sgml-font-lock-keywords-1 "*Rules for highlighting SGML code. See also `sgml-tag-face-alist'.") -(defvar sgml-font-lock-syntactic-keywords +(defconst sgml-syntax-propertize-function + (syntax-propertize-rules ;; Use the `b' style of comments to avoid interference with the -- ... -- ;; comments recognized when `sgml-specials' includes ?-. ;; FIXME: beware of <!--> blabla <!--> !! - '(("\\(<\\)!--" (1 "< b")) + ("\\(<\\)!--" (1 "< b")) ("--[ \t\n]*\\(>\\)" (1 "> b")) ;; Double quotes outside of tags should not introduce strings. ;; Be careful to call `syntax-ppss' on a position before the one we're @@ -477,9 +478,9 @@ '((sgml-font-lock-keywords sgml-font-lock-keywords-1 sgml-font-lock-keywords-2) - nil t nil nil - (font-lock-syntactic-keywords - . sgml-font-lock-syntactic-keywords))) + nil t)) + (set (make-local-variable 'syntax-propertize-function) + sgml-syntax-propertize-function) (set (make-local-variable 'facemenu-add-face-function) 'sgml-mode-facemenu-add-face-function) (set (make-local-variable 'sgml-xml-mode) (sgml-xml-guess))
--- a/lisp/textmodes/tex-mode.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/tex-mode.el Wed Sep 22 15:46:51 2010 +0900 @@ -488,10 +488,6 @@ ;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)")) (arg "{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)")) (list - ;; font-lock-syntactic-keywords causes the \ of \end{verbatim} to be - ;; highlighted as tex-verbatim face. Let's undo that. - ;; This is ugly and brittle :-( --Stef - '("^\\(\\\\\\)end" (1 (get-text-property (match-end 1) 'face) t)) ;; display $$ math $$ ;; We only mark the match between $$ and $$ because the $$ delimiters ;; themselves have already been marked (along with $..$) by syntactic @@ -642,28 +638,90 @@ (put 'tex-verbatim-environments 'safe-local-variable (lambda (x) (null (delq t (mapcar 'stringp x))))) -(defvar tex-font-lock-syntactic-keywords - '((eval . `(,(concat "^\\\\begin *{" - (regexp-opt tex-verbatim-environments t) - "}.*\\(\n\\)") 2 "|")) - ;; Technically, we'd like to put the "|" property on the \n preceding - ;; the \end, but this would have 2 disadvantages: - ;; 1 - it's wrong if the verbatim env is empty (the same \n is used to - ;; start and end the fenced-string). - ;; 2 - font-lock considers the preceding \n as being part of the - ;; preceding line, so things gets screwed every time the previous - ;; line is re-font-locked on its own. - ;; There's a hack in tex-font-lock-keywords-1 to remove the verbatim - ;; face from the \ but C-M-f still jumps to the wrong spot :-( --Stef - (eval . `(,(concat "^\\(\\\\\\)end *{" - (regexp-opt tex-verbatim-environments t) - "}\\(.?\\)") (1 "|") (3 "<"))) - ;; ("^\\(\\\\\\)begin *{comment}" 1 "< b") - ;; ("^\\\\end *{comment}.*\\(\n\\)" 1 "> b") +(eval-when-compile + (defconst tex-syntax-propertize-rules + (syntax-propertize-precompile-rules ("\\\\verb\\**\\([^a-z@*]\\)" - ;; Do it last, because it uses syntax-ppss which needs the - ;; syntax-table properties of previous entries. - 1 (tex-font-lock-verb (match-end 1))))) + (1 (prog1 "\"" + (tex-font-lock-verb + (match-beginning 0) (char-after (match-beginning 1)))))))) + + (defconst latex-syntax-propertize-rules + (syntax-propertize-precompile-rules + tex-syntax-propertize-rules + ("\\\\\\(?:end\\|begin\\) *\\({[^\n{}]*}\\)" + (1 (ignore + (tex-env-mark (match-beginning 0) + (match-beginning 1) (match-end 1)))))))) + +(defun tex-env-mark (cmd start end) + (when (= cmd (line-beginning-position)) + (let ((arg (buffer-substring-no-properties (1+ start) (1- end)))) + (when (member arg tex-verbatim-environments) + (if (eq ?b (char-after (1+ cmd))) + ;; \begin + (put-text-property (line-end-position) + (line-beginning-position 2) + 'syntax-table (string-to-syntax "< c")) + ;; In the case of an empty verbatim env, the \n after the \begin is + ;; the same as the \n before the \end. Lucky for us, the "> c" + ;; property associated to the \end will be placed afterwards, so it + ;; will override the "< c". + (put-text-property (1- cmd) cmd + 'syntax-table (string-to-syntax "> c")) + ;; The text between \end{verbatim} and \n is ignored, so we'll treat + ;; it as a comment. + (put-text-property end (min (1+ end) (line-end-position)) + 'syntax-table (string-to-syntax "<")))))) + ;; Mark env args for possible electric pairing. + (unless (get-char-property (1+ start) 'text-clones) ;Already paired-up. + (put-text-property start end 'latex-env-pair t))) + +(define-minor-mode latex-electric-env-pair-mode + "Automatically update the \\end arg when editing the \\begin one. +And vice-versa." + :lighter "/e" + (if latex-electric-env-pair-mode + (add-hook 'before-change-functions + #'latex-env-before-change nil 'local) + (remove-hook 'before-change-functions + #'latex-env-before-change 'local))) + +(defun latex-env-before-change (start end) + (when (get-text-property start 'latex-env-pair) + (condition-case err + (with-silent-modifications + ;; Remove properties even if don't find a pair. + (remove-text-properties + (previous-single-property-change (1+ start) 'latex-env-pair) + (next-single-property-change start 'latex-env-pair) + '(latex-env-pair)) + (unless (or (get-char-property start 'text-clones) + (get-char-property (1+ start) 'text-clones) + (save-excursion + (goto-char start) + (not (re-search-backward + "\\\\\\(?:end\\|begi\\(n\\)\\) *{" + (line-beginning-position) t)))) + (let ((cmd-start (match-beginning 0)) + (type (match-end 1)) ;nil for \end, else \begin. + (arg-start (1- (match-end 0)))) + (save-excursion + (goto-char (match-end 0)) + (when (and (looking-at "[^\n{}]*}") + (> (match-end 0) end)) + (let ((arg-end (match-end 0))) + (if (null type) ;\end + (progn (goto-char arg-end) + (latex-forward-sexp -1) (forward-word 1)) + (goto-char cmd-start) + (latex-forward-sexp 1) + (let (forward-sexp-function) (backward-sexp))) + (when (looking-at + (regexp-quote (buffer-substring arg-start arg-end))) + (text-clone-create arg-start arg-end)))))))) + (scan-error nil) + (error (message "Error in latex-env-before-change: %s" err))))) (defun tex-font-lock-unfontify-region (beg end) (font-lock-default-unfontify-region beg end) @@ -730,37 +788,32 @@ (define-obsolete-face-alias 'tex-verbatim-face 'tex-verbatim "22.1") (defvar tex-verbatim-face 'tex-verbatim) -(defun tex-font-lock-verb (end) - "Place syntax-table properties on the \verb construct. -END is the position of the first delimiter after \verb." - (unless (nth 8 (syntax-ppss end)) +(defun tex-font-lock-verb (start delim) + "Place syntax table properties on the \verb construct. +START is the position of the \\ and DELIM is the delimiter char." ;; Do nothing if the \verb construct is itself inside a comment or ;; verbatim env. - (save-excursion + (unless (nth 8 (save-excursion (syntax-ppss start))) ;; Let's find the end and mark it. - ;; We used to do it inside tex-font-lock-syntactic-face-function, but - ;; this leads to funny effects when jumping to the end of the buffer, - ;; because font-lock applies font-lock-syntactic-keywords to the whole - ;; preceding text but font-lock-syntactic-face-function only to the - ;; actually displayed text. - (goto-char end) - (let ((char (char-before))) - (skip-chars-forward (string ?^ char)) ;; Use `end' ? - (when (eq (char-syntax (preceding-char)) ?/) - (put-text-property (1- (point)) (point) 'syntax-table '(1))) + ;; This may span more than a single line, but we don't bother + ;; placing a syntax-multiline property since such multiline verbs aren't + ;; valid anyway. + (skip-chars-forward (string ?^ delim)) (unless (eobp) - (put-text-property (point) (1+ (point)) 'syntax-table '(7)) - ;; Cause the rest of the buffer to be re-fontified. - ;; (remove-text-properties (1+ (point)) (point-max) '(fontified)) - ))) - "\"")) + (when (eq (char-syntax (preceding-char)) ?/) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "."))) + (put-text-property (point) (1+ (point)) + 'syntax-table (string-to-syntax "\""))))) ;; Use string syntax but math face for $...$. (defun tex-font-lock-syntactic-face-function (state) (let ((char (nth 3 state))) (cond - ((not char) font-lock-comment-face) + ((not char) + (if (eq 2 (nth 7 state)) tex-verbatim-face font-lock-comment-face)) ((eq char ?$) tex-math-face) + ;; A \verb element. (t tex-verbatim-face)))) @@ -1163,10 +1216,9 @@ (font-lock-syntactic-face-function . tex-font-lock-syntactic-face-function) (font-lock-unfontify-region-function - . tex-font-lock-unfontify-region) - (font-lock-syntactic-keywords - . tex-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + . tex-font-lock-unfontify-region))) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules latex-syntax-propertize-rules)) ;; TABs in verbatim environments don't do what you think. (set (make-local-variable 'indent-tabs-mode) nil) ;; Other vars that should be buffer-local. @@ -2812,15 +2864,15 @@ ;; syntax-table can't deal with. We could turn it ;; into a non-comment, or use `\n%' or `%^' as the comment. ;; Instead, we include it in the ^^A comment. - (eval-when-compile (string-to-syntax "< b")) - (eval-when-compile (string-to-syntax ">")))) + (string-to-syntax "< b") + (string-to-syntax ">"))) (let ((end (line-end-position))) (if (< end (point-max)) (put-text-property end (1+ end) 'syntax-table - (eval-when-compile (string-to-syntax "> b"))))) - (eval-when-compile (string-to-syntax "< b"))))) + (string-to-syntax "> b")))) + (string-to-syntax "< b")))) (defun doctex-font-lock-syntactic-face-function (state) ;; Mark DocTeX documentation, which is parsed as a style A comment @@ -2832,11 +2884,12 @@ (tex-font-lock-syntactic-face-function state) font-lock-doc-face)) -(defvar doctex-font-lock-syntactic-keywords - (append - tex-font-lock-syntactic-keywords - ;; For DocTeX comment-in-doc. - `(("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A)))))) +(eval-when-compile + (defconst doctex-syntax-propertize-rules + (syntax-propertize-precompile-rules + latex-syntax-propertize-rules + ;; For DocTeX comment-in-doc. + ("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A)))))) (defvar doctex-font-lock-keywords (append tex-font-lock-keywords @@ -2850,12 +2903,12 @@ (mapcar (lambda (x) (case (car-safe x) - (font-lock-syntactic-keywords - (cons (car x) 'doctex-font-lock-syntactic-keywords)) (font-lock-syntactic-face-function (cons (car x) 'doctex-font-lock-syntactic-face-function)) (t x))) - (cdr font-lock-defaults))))) + (cdr font-lock-defaults)))) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules doctex-syntax-propertize-rules))) (run-hooks 'tex-mode-load-hook)
--- a/lisp/textmodes/texinfo.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/textmodes/texinfo.el Wed Sep 22 15:46:51 2010 +0900 @@ -310,10 +310,11 @@ ("Chapters" "^@chapter[ \t]+\\(.*\\)$" 1)) "Imenu generic expression for Texinfo mode. See `imenu-generic-expression'.") -(defvar texinfo-font-lock-syntactic-keywords - '(("\\(@\\)c\\(omment\\)?\\>" (1 "<")) - ("^\\(@\\)ignore\\>" (1 "< b")) - ("^@end ignore\\(\n\\)" (1 "> b"))) +(defconst texinfo-syntax-propertize-function + (syntax-propertize-rules + ("\\(@\\)c\\(omment\\)?\\>" (1 "<")) + ("^\\(@\\)ignore\\>" (1 "< b")) + ("^@end ignore\\(\n\\)" (1 "> b"))) "Syntactic keywords to catch comment delimiters in `texinfo-mode'.") (defconst texinfo-environments @@ -600,9 +601,9 @@ (setq imenu-case-fold-search nil) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults - '(texinfo-font-lock-keywords nil nil nil backward-paragraph - (font-lock-syntactic-keywords - . texinfo-font-lock-syntactic-keywords))) + '(texinfo-font-lock-keywords nil nil nil backward-paragraph)) + (set (make-local-variable 'syntax-propertize-function) + texinfo-syntax-propertize-function) (set (make-local-variable 'parse-sexp-lookup-properties) t) ;; Outline settings.
--- a/lisp/tool-bar.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/tool-bar.el Wed Sep 22 15:46:51 2010 +0900 @@ -311,6 +311,23 @@ 'help :help "Pop up the Help menu"))) +(if (featurep 'move-toolbar) + (defcustom tool-bar-position 'top + "Specify on which side the tool bar shall be. +Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom), +`left' (tool bar on left) and `right' (tool bar on right). +Customize `tool-bar-mode' if you want to show or hide the tool bar." + :type '(choice (const top) + (const bottom) + (const left) + (const right)) + :group 'frames + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (modify-all-frames-parameters + (list (cons 'tool-bar-position val)))))) + (provide 'tool-bar) ;; arch-tag: 15f30f0a-d0d7-4d50-bbb7-f48fd0c8582f
--- a/lisp/url/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,28 @@ +2010-09-19 Julien Danjou <julien@danjou.info> + + * url-cache.el (url-fetch-from-cache): New function. + +2010-09-18 Julien Danjou <julien@danjou.info> + + * url-vars.el (url-cache-expired): Remove unused variable. + +2010-09-14 Julien Danjou <julien@danjou.info> + + * url-cache (url-store-in-cache): Make `buff' argument really optional. + +2010-09-14 Glenn Morris <rgm@gnu.org> + + * url-cookie.el (url-cookie-expired-p): Tweak previous change. + +2010-09-14 shawn boles <shawn.boles@gmail.com> (tiny change) + + * url-cookie.el (url-cookie-expired-p): Simplify and fix. (Bug#6957) + +2010-09-11 Glenn Morris <rgm@gnu.org> + + * url-cache.el, url-gw.el, url-history.el, url-irc.el, url-util.el: + * url-vars.el: Remove leading `*' from defcustom docs. + 2010-07-27 Michael Albinus <michael.albinus@gmx.de> * url-http (url-http-parse-headers): Disable file name handlers at
--- a/lisp/url/url-cache.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-cache.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,7 @@ ;;; url-cache.el --- Uniform Resource Locator retrieval tool -;; Copyright (C) 1996, 1997, 1998, 1999, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -28,7 +28,7 @@ (defcustom url-cache-directory (expand-file-name "cache" url-configuration-directory) - "*The directory where cache files should be stored." + "The directory where cache files should be stored." :type 'directory :group 'url-file) @@ -62,14 +62,17 @@ ;;;###autoload (defun url-store-in-cache (&optional buff) "Store buffer BUFF in the cache." - (if (not (and buff (get-buffer buff))) - nil - (save-current-buffer - (and buff (set-buffer buff)) - (let* ((fname (url-cache-create-filename (url-view-url t)))) - (if (url-cache-prepare fname) - (let ((coding-system-for-write 'binary)) - (write-region (point-min) (point-max) fname nil 5))))))) + (with-current-buffer (get-buffer (or buff (current-buffer))) + (let ((fname (url-cache-create-filename (url-view-url t)))) + (if (url-cache-prepare fname) + (let ((coding-system-for-write 'binary)) + (write-region (point-min) (point-max) fname nil 5)))))) + +(defun url-fetch-from-cache (url) + "Fetch URL from cache and return a buffer with the content." + (with-current-buffer (generate-new-buffer " *temp*") + (url-cache-extract (url-cache-create-filename url)) + (current-buffer))) ;;;###autoload (defun url-is-cached (url) @@ -165,7 +168,7 @@ url-cache-directory)))))) (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5 - "*What function to use to create a cached filename." + "What function to use to create a cached filename." :type '(choice (const :tag "MD5 of filename (low collision rate)" :value url-cache-create-filename-using-md5) (const :tag "Human readable filenames (higher collision rate)"
--- a/lisp/url/url-cookie.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-cookie.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,7 @@ ;;; url-cookie.el --- Netscape Cookie support -;; Copyright (C) 1996, 1997, 1998, 1999, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -24,7 +24,6 @@ ;;; Code: -(require 'timezone) (require 'url-util) (require 'url-parse) (eval-when-compile (require 'cl)) @@ -194,34 +193,9 @@ (setq url-cookie-storage (list (list domain tmp)))))))) (defun url-cookie-expired-p (cookie) - (let* ( - (exp (url-cookie-expires cookie)) - (cur-date (and exp (timezone-parse-date (current-time-string)))) - (exp-date (and exp (timezone-parse-date exp))) - (cur-greg (and cur-date (timezone-absolute-from-gregorian - (string-to-number (aref cur-date 1)) - (string-to-number (aref cur-date 2)) - (string-to-number (aref cur-date 0))))) - (exp-greg (and exp (timezone-absolute-from-gregorian - (string-to-number (aref exp-date 1)) - (string-to-number (aref exp-date 2)) - (string-to-number (aref exp-date 0))))) - (diff-in-days (and exp (- cur-greg exp-greg))) - ) - (cond - ((not exp) nil) ; No expiry == expires at browser quit - ((< diff-in-days 0) nil) ; Expires sometime after today - ((> diff-in-days 0) t) ; Expired before today - (t ; Expires sometime today, check times - (let* ((cur-time (timezone-parse-time (aref cur-date 3))) - (exp-time (timezone-parse-time (aref exp-date 3))) - (cur-norm (+ (* 360 (string-to-number (aref cur-time 2))) - (* 60 (string-to-number (aref cur-time 1))) - (* 1 (string-to-number (aref cur-time 0))))) - (exp-norm (+ (* 360 (string-to-number (aref exp-time 2))) - (* 60 (string-to-number (aref exp-time 1))) - (* 1 (string-to-number (aref exp-time 0)))))) - (> (- cur-norm exp-norm) 1)))))) + "Return non-nil if COOKIE is expired." + (let ((exp (url-cookie-expires cookie))) + (and exp (> (float-time) (float-time (date-to-time exp)))))) (defun url-cookie-retrieve (host &optional localpart secure) "Retrieve all the netscape-style cookies for a specified HOST and LOCALPART."
--- a/lisp/url/url-gw.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-gw.el Wed Sep 22 15:46:51 2010 +0900 @@ -37,50 +37,50 @@ :group 'url) (defcustom url-gateway-local-host-regexp nil - "*A regular expression specifying local hostnames/machines." + "A regular expression specifying local hostnames/machines." :type '(choice (const nil) regexp) :group 'url-gateway) (defcustom url-gateway-prompt-pattern "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?" - "*A regular expression matching a shell prompt." + "A regular expression matching a shell prompt." :type 'regexp :group 'url-gateway) (defcustom url-gateway-rlogin-host nil - "*What hostname to actually rlog into before doing a telnet." + "What hostname to actually rlog into before doing a telnet." :type '(choice (const nil) string) :group 'url-gateway) (defcustom url-gateway-rlogin-user-name nil - "*Username to log into the remote machine with when using rlogin." + "Username to log into the remote machine with when using rlogin." :type '(choice (const nil) string) :group 'url-gateway) (defcustom url-gateway-rlogin-parameters '("telnet" "-8") - "*Parameters to `url-open-rlogin'. + "Parameters to `url-open-rlogin'. This list will be used as the parameter list given to rsh." :type '(repeat string) :group 'url-gateway) (defcustom url-gateway-telnet-host nil - "*What hostname to actually login to before doing a telnet." + "What hostname to actually login to before doing a telnet." :type '(choice (const nil) string) :group 'url-gateway) (defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8") - "*Parameters to `url-open-telnet'. + "Parameters to `url-open-telnet'. This list will be executed as a command after logging in via telnet." :type '(repeat string) :group 'url-gateway) (defcustom url-gateway-telnet-login-prompt "^\r*.?login:" - "*Prompt that tells us we should send our username when loggin in w/telnet." + "Prompt that tells us we should send our username when loggin in w/telnet." :type 'regexp :group 'url-gateway) (defcustom url-gateway-telnet-password-prompt "^\r*.?password:" - "*Prompt that tells us we should send our password when loggin in w/telnet." + "Prompt that tells us we should send our password when loggin in w/telnet." :type 'regexp :group 'url-gateway) @@ -95,7 +95,7 @@ :group 'url-gateway) (defcustom url-gateway-broken-resolution nil - "*Whether to use nslookup to resolve hostnames. + "Whether to use nslookup to resolve hostnames. This should be used when your version of Emacs cannot correctly use DNS, but your machine can. This usually happens if you are running a statically linked Emacs under SunOS 4.x." @@ -103,7 +103,7 @@ :group 'url-gateway) (defcustom url-gateway-nslookup-program "nslookup" - "*If non-nil then a string naming nslookup program." + "If non-nil then a string naming nslookup program." :type '(choice (const :tag "None" :value nil) string) :group 'url-gateway)
--- a/lisp/url/url-history.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-history.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,7 @@ ;;; url-history.el --- Global history tracking for URL package -;; Copyright (C) 1996, 1997, 1998, 1999, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -35,7 +35,7 @@ :group 'url) (defcustom url-history-track nil - "*Controls whether to keep a list of all the URLs being visited. + "Controls whether to keep a list of all the URLs being visited. If non-nil, the URL package will keep track of all the URLs visited. If set to t, then the list is saved to disk at the end of each Emacs session." @@ -49,14 +49,14 @@ :group 'url-history) (defcustom url-history-file nil - "*The global history file for the URL package. + "The global history file for the URL package. This file contains a list of all the URLs you have visited. This file is parsed at startup and used to provide URL completion." :type '(choice (const :tag "Default" :value nil) file) :group 'url-history) (defcustom url-history-save-interval 3600 - "*The number of seconds between automatic saves of the history list. + "The number of seconds between automatic saves of the history list. Default is 1 hour. Note that if you change this variable outside of the `customize' interface after `url-do-setup' has been run, you need to run the `url-history-setup-save-timer' function manually."
--- a/lisp/url/url-irc.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-irc.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,7 @@ ;;; url-irc.el --- IRC URL interface -;; Copyright (C) 1996, 1997, 1998, 1999, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Keywords: comm, data, processes @@ -22,7 +22,8 @@ ;;; Commentary: -;; IRC URLs are defined in http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt +;; IRC URLs are defined in +;; http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt ;;; Code: @@ -32,7 +33,7 @@ (defconst url-irc-default-port 6667 "Default port for IRC connections.") (defcustom url-irc-function 'url-irc-rcirc - "*Function to actually open an IRC connection. + "Function to actually open an IRC connection. The function should take the following arguments: HOST - the hostname of the IRC server to contact PORT - the port number of the IRC server to contact
--- a/lisp/url/url-util.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-util.el Wed Sep 22 15:46:51 2010 +0900 @@ -43,7 +43,7 @@ ;;;###autoload (defcustom url-debug nil - "*What types of debug messages from the URL library to show. + "What types of debug messages from the URL library to show. Debug messages are logged to the *URL-DEBUG* buffer. If t, all messages will be logged.
--- a/lisp/url/url-vars.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/url/url-vars.el Wed Sep 22 15:46:51 2010 +0900 @@ -1,7 +1,7 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool -;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -68,7 +68,7 @@ )) (defcustom url-honor-refresh-requests t - "*Whether to do automatic page reloads. + "Whether to do automatic page reloads. These are done at the request of the document author or the server via the `Refresh' header in an HTTP response. If nil, no refresh requests will be honored. If t, all refresh requests will be honored. @@ -79,31 +79,22 @@ :group 'url-hairy) (defcustom url-automatic-caching nil - "*If non-nil, all documents will be automatically cached to the local disk." + "If non-nil, all documents will be automatically cached to the local disk." :type 'boolean :group 'url-cache) -;; Fixme: sanitize this. -(defcustom url-cache-expired - (lambda (t1 t2) (>= (- (car t2) (car t1)) 5)) - "*A function determining if a cached item has expired. -It takes two times (numbers) as its arguments, and returns non-nil if -the second time is 'too old' when compared to the first time." - :type 'function - :group 'url-cache) - (defconst url-bug-address "bug-gnu-emacs@gnu.org" "Where to send bug reports.") (defcustom url-personal-mail-address nil - "*Your full email address. + "Your full email address. This is what is sent to HTTP servers as the FROM field in an HTTP request." :type '(choice (const :tag "Unspecified" nil) string) :group 'url) (defcustom url-directory-index-file "index.html" - "*The filename to look for when indexing a directory. + "The filename to look for when indexing a directory. If this file exists, and is readable, then it will be viewed instead of using `dired' to view the directory." :type 'string @@ -166,14 +157,14 @@ (".hqx" . "x-hqx") (".Z" . "x-compress") (".bz2" . "x-bzip2")) - "*An alist of file extensions and appropriate content-transfer-encodings." + "An alist of file extensions and appropriate content-transfer-encodings." :type '(repeat (cons :format "%v" (string :tag "Extension") (string :tag "Encoding"))) :group 'url-mime) (defcustom url-mail-command 'compose-mail - "*This function will be called whenever URL needs to send mail. + "This function will be called whenever URL needs to send mail. It should enter a mail-mode-like buffer in the current window. The commands `mail-to' and `mail-subject' should still work in this buffer, and it should use `mail-header-separator' if possible." @@ -181,7 +172,7 @@ :group 'url) (defcustom url-proxy-services nil - "*An alist of schemes and proxy servers that gateway them. + "An alist of schemes and proxy servers that gateway them. Looks like ((\"http\" . \"hostname:portnumber\") ...). This is set up from the ACCESS_proxy environment variables." :type '(repeat (cons :format "%v" @@ -190,7 +181,7 @@ :group 'url) (defcustom url-standalone-mode nil - "*Rely solely on the cache?" + "Rely solely on the cache?" :type 'boolean :group 'url-cache) @@ -202,7 +193,7 @@ (defcustom url-bad-port-list '("25" "119" "19") - "*List of ports to warn the user about connecting to. + "List of ports to warn the user about connecting to. Defaults to just the mail, chargen, and NNTP ports so you cannot be tricked into sending fake mail or forging messages by a malicious HTML document." @@ -255,7 +246,7 @@ ;; Fixme: set from the locale. (defcustom url-mime-language-string nil - "*String to send in the Accept-language: field in HTTP requests. + "String to send in the Accept-language: field in HTTP requests. Specifies the preferred language when servers can serve documents in several languages. Use RFC 1766 abbreviations, e.g.: `en' for @@ -284,20 +275,20 @@ "What OS we are on.") (defcustom url-max-password-attempts 5 - "*Maximum number of times a password will be prompted for. + "Maximum number of times a password will be prompted for. Applies when a protected document is denied by the server." :type 'integer :group 'url) (defcustom url-temporary-directory (or (getenv "TMPDIR") "/tmp") - "*Where temporary files go." + "Where temporary files go." :type 'directory :group 'url-file) (make-obsolete-variable 'url-temporary-directory 'temporary-file-directory "23.1") (defcustom url-show-status t - "*Whether to show a running total of bytes transferred. + "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." :type 'boolean @@ -308,7 +299,7 @@ http://www.example.com/") (defcustom url-news-server nil - "*The default news server from which to get newsgroups/articles. + "The default news server from which to get newsgroups/articles. Applies if no server is specified in the URL. Defaults to the environment variable NNTPSERVER or \"news\" if NNTPSERVER is undefined." @@ -320,13 +311,13 @@ "A regular expression that will match an absolute URL.") (defcustom url-max-redirections 30 - "*The maximum number of redirection requests to honor in a HTTP connection. + "The maximum number of redirection requests to honor in a HTTP connection. A negative number means to honor an unlimited number of redirection requests." :type 'integer :group 'url) (defcustom url-confirmation-func 'y-or-n-p - "*What function to use for asking yes or no functions. + "What function to use for asking yes or no functions. Possible values are `yes-or-no-p' or `y-or-n-p', or any function that takes a single argument (the prompt), and returns t only if a positive answer is given." @@ -336,7 +327,7 @@ :group 'url-hairy) (defcustom url-gateway-method 'native - "*The type of gateway support to use. + "The type of gateway support to use. Should be a symbol specifying how to get a connection from the local machine. Currently supported methods:
--- a/lisp/vc/vc-hg.el Wed Sep 08 12:55:57 2010 +0900 +++ b/lisp/vc/vc-hg.el Wed Sep 22 15:46:51 2010 +0900 @@ -171,10 +171,12 @@ (let ((process-environment ;; Avoid localization of messages so we ;; can parse the output. - (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=") + (append (list "TERM=dumb" "LANGUAGE=C") process-environment))) (process-file "hg" nil t nil + "--config" "alias.status=status" + "--config" "defaults.status=" "status" "-A" (file-relative-name file))) ;; Some problem happened. E.g. We can't find an `hg' ;; executable. @@ -199,7 +201,7 @@ ((status nil) (default-directory (file-name-directory file)) ;; Avoid localization of messages so we can parse the output. - (avoid-local-env (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=") + (avoid-local-env (append (list "TERM=dumb" "LANGUAGE=C") process-environment)) (out (with-output-to-string @@ -211,6 +213,8 @@ ;; Ignore all errors. (process-file "hg" nil t nil + "--config" "alias.parents=parents" + "--config" "defaults.parents=" "parents" "--template" "{rev}" (file-relative-name file))) ;; Some problem happened. E.g. We can't find an `hg' ;; executable.
--- a/lwlib/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/lwlib/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,9 @@ +2010-09-20 Dan Nicolaescu <dann@ics.uci.edu> + + * lwlib.h (lw_register_widget, lw_create_widget): + * lwlib.c (allocate_widget_info, lw_register_widget) + (lw_create_widget, separator_table): Use const. + 2010-07-29 Dan Nicolaescu <dann@ics.uci.edu> * xlwmenu.c (abort_gracefully): Mark as NO_RETURN.
--- a/lwlib/lwlib.c Wed Sep 08 12:55:57 2010 +0900 +++ b/lwlib/lwlib.c Wed Sep 22 15:46:51 2010 +0900 @@ -66,9 +66,9 @@ all_widget_info = NULL; #ifdef USE_MOTIF -char *lwlib_toolkit_type = "motif"; +const char *lwlib_toolkit_type = "motif"; #else -char *lwlib_toolkit_type = "lucid"; +const char *lwlib_toolkit_type = "lucid"; #endif static widget_value *merge_widget_value (widget_value *, @@ -80,7 +80,7 @@ static void free_widget_value_tree (widget_value *); static widget_value *copy_widget_value_tree (widget_value *, change_type); -static widget_info *allocate_widget_info (char *, char *, LWLIB_ID, +static widget_info *allocate_widget_info (const char *, const char *, LWLIB_ID, widget_value *, lw_callback, lw_callback, lw_callback, lw_callback); @@ -249,8 +249,8 @@ } static widget_info * -allocate_widget_info (char* type, - char* name, +allocate_widget_info (const char* type, + const char* name, LWLIB_ID id, widget_value* val, lw_callback pre_activate_cb, @@ -823,8 +823,8 @@ } void -lw_register_widget (char* type, - char* name, +lw_register_widget (const char* type, + const char* name, LWLIB_ID id, widget_value* val, lw_callback pre_activate_cb, @@ -867,7 +867,7 @@ } Widget -lw_create_widget (char* type, char* name, LWLIB_ID id, widget_value* val, +lw_create_widget (const char* type, const char* name, LWLIB_ID id, widget_value* val, Widget parent, Boolean pop_up_p, lw_callback pre_activate_cb, lw_callback selection_cb, lw_callback post_activate_cb, lw_callback highlight_cb) @@ -1326,7 +1326,7 @@ { static struct separator_table { - char *name; + const char *name; enum menu_separator type; } separator_names[] = @@ -1371,7 +1371,7 @@ /* Alternative, more Emacs-style names. */ static struct separator_table { - char *name; + const char *name; enum menu_separator type; } separator_names[] =
--- a/lwlib/lwlib.h Wed Sep 08 12:55:57 2010 +0900 +++ b/lwlib/lwlib.h Wed Sep 22 15:46:51 2010 +0900 @@ -132,14 +132,14 @@ typedef void (*lw_callback) (Widget w, LWLIB_ID id, void* data); -void lw_register_widget (char* type, char* name, LWLIB_ID id, +void lw_register_widget (const char* type, const char* name, LWLIB_ID id, widget_value* val, lw_callback pre_activate_cb, lw_callback selection_cb, lw_callback post_activate_cb, lw_callback highlight_cb); Widget lw_get_widget (LWLIB_ID id, Widget parent, Boolean pop_up_p); Widget lw_make_widget (LWLIB_ID id, Widget parent, Boolean pop_up_p); -Widget lw_create_widget (char* type, char* name, LWLIB_ID id, +Widget lw_create_widget (const char* type, const char* name, LWLIB_ID id, widget_value* val, Widget parent, Boolean pop_up_p, lw_callback pre_activate_cb, lw_callback selection_cb,
--- a/make-dist Wed Sep 08 12:55:57 2010 +0900 +++ b/make-dist Wed Sep 22 15:46:51 2010 +0900 @@ -398,10 +398,10 @@ mkdir -p ../${tempdir}/lisp/$file ln $file/[a-zA-Z0-9]*.el ../${tempdir}/lisp/$file ln $file/[a-zA-Z0-9]*.elc ../${tempdir}/lisp/$file - ## calc/README.priv, nxml/TODO + ## calc/README.priv for f in $file/[a-zA-Z]*.xpm $file/[a-zA-Z]*.[xp]bm \ $file/README $file/ChangeLog $file/ChangeLog.*[0-9] \ - $file/README.prev $file/TODO; do + $file/README.prev; do if [ -f $f ]; then ln $f ../${tempdir}/lisp/$file fi
--- a/msdos/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/msdos/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,7 @@ +2010-09-17 Eli Zaretskii <eliz@gnu.org> + + * sed1v2.inp (LIBXML2_LIBS, LIBXML2_CFLAGS): Edit to empty. + 2010-08-22 Chong Yidong <cyd@stupidchicken.com> * sedleim.inp (RUN-EMACS): Don't use --multibyte.
--- a/msdos/sed1v2.inp Wed Sep 08 12:55:57 2010 +0900 +++ b/msdos/sed1v2.inp Wed Sep 22 15:46:51 2010 +0900 @@ -90,6 +90,8 @@ /^RSVG_CFLAGS *=/s/@RSVG_CFLAGS@// /^IMAGEMAGICK_LIBS *=/s/@IMAGEMAGICK_LIBS@// /^IMAGEMAGICK_CFLAGS *=/s/@IMAGEMAGICK_CFLAGS@// +/^LIBXML2_LIBS *=/s/@LIBXML2_LIBS@// +/^LIBXML2_CFLAGS *=/s/@LIBXML2_CFLAGS@// /^WIDGET_OBJ *=/s/@WIDGET_OBJ@// /^CYGWIN_OBJ *=/s/@CYGWIN_OBJ@// /^MSDOS_OBJ *=/s/= */= dosfns.o msdos.o w16select.o/
--- a/nt/configure.bat Wed Sep 08 12:55:57 2010 +0900 +++ b/nt/configure.bat Wed Sep 22 15:46:51 2010 +0900 @@ -1,6 +1,6 @@ @echo off rem ---------------------------------------------------------------------- -rem Configuration script for MS Windows 95/98/Me and NT/2000/XP +rem Configuration script for MS Windows operating systems rem Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, rem 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. @@ -22,7 +22,7 @@ rem ---------------------------------------------------------------------- rem YOU'LL NEED THE FOLLOWING UTILITIES TO MAKE EMACS: rem -rem + MS Windows 95/98/Me or NT/2000/XP +rem + MS Windows 95, NT or later rem + either MSVC 2.x or later, or gcc-2.95 or later (with GNU make 3.75 rem or later) and the Mingw32 and W32 API headers and libraries. rem + Visual Studio 2005 is not supported at this time. @@ -116,6 +116,7 @@ if "%1" == "--with-svg" goto withsvg if "%1" == "--distfiles" goto distfiles if "%1" == "" goto checkutils + :usage echo Usage: configure [options] echo Options: @@ -137,61 +138,82 @@ echo. --with-svg use the RSVG library (experimental) echo. --distfiles path to files for make dist, e.g. libXpm.dll goto end + rem ---------------------------------------------------------------------- + :setprefix shift set prefix=%1 shift goto again + rem ---------------------------------------------------------------------- + :withgcc set COMPILER=gcc shift goto again + rem ---------------------------------------------------------------------- + :withmsvc set COMPILER=cl shift goto again + rem ---------------------------------------------------------------------- + :nodebug set nodebug=Y shift goto again + rem ---------------------------------------------------------------------- + :noopt set noopt=Y shift goto again + rem ---------------------------------------------------------------------- + :enablechecking set enablechecking=Y shift goto again + rem ---------------------------------------------------------------------- + :profile set profile=Y shift goto again + rem ---------------------------------------------------------------------- + :nocygwin set nocygwin=Y shift goto again + rem ---------------------------------------------------------------------- + :usercflags shift set usercflags=%usercflags%%sep1%%1 set sep1= %nothing% shift goto again + rem ---------------------------------------------------------------------- + :userldflags shift set userldflags=%userldflags%%sep2%%1 set sep2= %nothing% shift goto again + rem ---------------------------------------------------------------------- :withoutpng @@ -249,6 +271,7 @@ rem ---------------------------------------------------------------------- rem Check that necessary utilities (cp and rm) are present. + :checkutils echo Checking for 'cp'... cp configure.bat junk.bat @@ -257,9 +280,11 @@ rm junk.bat if exist junk.bat goto needrm goto checkcompiler + :needcp echo You need 'cp' (the Unix file copy program) to build Emacs. goto end + :needrm del junk.bat echo You need 'rm' (the Unix file delete program) to build Emacs. @@ -267,6 +292,7 @@ rem ---------------------------------------------------------------------- rem Auto-detect compiler if not specified, and validate GCC if chosen. + :checkcompiler if (%COMPILER%)==(cl) goto compilercheckdone if (%COMPILER%)==(gcc) goto checkgcc @@ -301,6 +327,7 @@ :chkapi echo The failed program was: >>config.log type junk.c >>config.log + :chkapiN rm -f junk.c junk.o rem ---------------------------------------------------------------------- @@ -320,8 +347,10 @@ if (%nocygwin%) == (Y) goto chkapi1 set cf=%usercflags% goto chkapi2 + :chkapi1 set cf=%usercflags% -mno-cygwin + :chkapi2 echo on gcc %cf% -c junk.c @@ -357,10 +386,12 @@ set mf=-mcpu=i686 rm -f junk.c junk.o goto gccdebug + :gccMtuneOk echo GCC supports -mtune=pentium4 >>config.log set mf=-mtune=pentium4 rm -f junk.c junk.o + :gccdebug rem Check for DWARF-2 debug info support, else default to stabs echo main(){} >junk.c @@ -372,6 +403,7 @@ set dbginfo=-gstabs+ rm -f junk.c junk.o goto compilercheckdone + :gccdwarf echo GCC supports DWARF-2 >>config.log set dbginfo=-gdwarf-2 -g3 @@ -565,6 +597,7 @@ set fileNotFound= rem ---------------------------------------------------------------------- + :genmakefiles echo Generating makefiles if %COMPILER% == gcc set MAKECMD=gmake @@ -619,6 +652,7 @@ if errorlevel 1 goto doCopy fc /b paths.h ..\src\epaths.h >nul 2>&1 if errorlevel 0 goto dontCopy + :doCopy copy config.tmp ..\src\config.h copy paths.h ..\src\epaths.h @@ -648,6 +682,7 @@ if not errorlevel 2 goto doUpdateSubdirs fc /b subdirs.el ..\site-lisp\subdirs.el >nul 2>&1 if not errorlevel 1 goto dontUpdateSubdirs + :doUpdateSubdirs if exist ..\site-lisp\subdirs.el del ..\site-lisp\subdirs.el copy subdirs.el ..\site-lisp\subdirs.el @@ -716,6 +751,7 @@ echo Your environment size is too small. Please enlarge it and rerun configure. echo For example, type "command.com /e:2048" to have 2048 bytes available. set $foo$= + :end set prefix= set nodebug=
--- a/src/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/src/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,182 @@ +2010-09-22 Kenichi Handa <handa@m17n.org> + + * xdisp.c (compute_stop_pos): Call composition_compute_stop_pos + only if we are not at a composition. + (set_iterator_to_next): Give it->end_charpos to + composition_compute_stop_pos. + (set_iterator_to_next, next_element_from_buffer): Likewise. + + * dispnew.c (buffer_posn_from_coords): Fix position when the + current display element is a grapheme cluster in bidi-reordered + region. + +2010-09-21 Ari Roponen <ari.roponen@gmail.com> (tiny change) + + * doc.c (Fsnarf_documentation): Use memmove instead of memcpy as + the regions may overlap. + +2010-09-21 Juanma Barranquero <lekktu@gmail.com> + + * makefile.w32-in ($(BLD)/sysdep.$(O)): Update dependencies. + +2010-09-21 Dan Nicolaescu <dann@ics.uci.edu> + + * emacs.c: Do not include sys/ioctl.h, not needed. + + * doprnt.c: Do not include stdlib.h, config.h does it. + Move #include before macro definition. + +2010-09-20 Dan Nicolaescu <dann@ics.uci.edu> + + * Makefile.in (temacs): Link using $(CC) not $(LD). + (LD_FIRSTFLAG): Define using autoconf. + (LD): Remove. + + Remove HAVE_TERMIOS definitions. + * s/usg5-4-common.h (HAVE_TERMIOS): + * s/template.h (HAVE_TERMIOS): + * s/gnu-linux.h (HAVE_TERMIOS): + * s/darwin.h (HAVE_TERMIOS): + * s/cygwin.h (HAVE_TERMIOS): + * s/bsd-common.h (HAVE_TERMIOS): + * s/aix4-2.h (HAVE_TERMIOS): + * s/hpux10-20.h (HAVE_TERMIOS): Do not define, it is assumed + defined on all non-MS platforms. + (HAVE_PSTAT_GETDYNAMIC): Do not define, autoconf does it. + + * xterm.c (xt_action_hook): Use const. + +2010-09-20 Juanma Barranquero <lekktu@gmail.com> + + Don't make W32 code conditional on HAVE_SOCKETS, it's always defined. + * w32.c: Remove top-level uses of #ifdef HAVE_SOCKETS. + (gethostname) [!HAVE_SOCKETS]: Remove. + (SOCK_REPLACE_HANDLE): Remove macro. + (socket_to_fd, sys_close, _sys_read_ahead, sys_read, sys_write) + (term_ntproc, init_ntproc): Don't conditionalize on HAVE_SOCKETS. + * w32proc.c: Remove top-level uses of #ifdef HAVE_SOCKETS. + (syms_of_ntproc): Don't conditionalize on HAVE_SOCKETS. + +2010-09-18 Eli Zaretskii <eliz@gnu.org> + + * deps.mk (xml.o): Add dependencies. + + * xdisp.c (Fcurrent_bidi_paragraph_direction): + Call bidi_paragraph_init with NO_DEFAULT_P non-zero. (Bug#7038) + + * bidi.c (bidi_paragraph_init): Accept an additional argument + NO_DEFAULT_P; all callers changed. If NO_DEFAULT_P is non-zero, + search back until a paragraph with a strong directional character + is found, and use that to determine paragraph's base direction. + + * dispextern.h (bidi_paragraph_init): Update prototype. + +2010-09-17 Eli Zaretskii <eliz@gnu.org> + + * w32.c (_PROCESS_MEMORY_COUNTERS_EX): Don't define with versions + of w32api >= 3.15. (Bug#6989) + +2010-09-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * process.c (wait_reading_process_output): Don't message about + accept-process-output unless the time limit really is zero. + +2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * frame.c (Ftool_bar_pixel_width): YAILOM (Yet another + int/Lisp_Object mixup). + +2010-09-17 Jan Djärv <jan.h.d@swipnet.se> + + * keyboard.c (parse_tool_bar_item): For QClabel, set TOOL_BAR_ITEM_LABEL + not HELP. + +2010-09-17 Stephen Berman <stephen.berman@gmx.net> + + * frame.c (Ftool_bar_pixel_width): New function to expose tool + bar's pixel width to Lisp (Bug#7048). + +2010-09-14 Juanma Barranquero <lekktu@gmail.com> + + * cmds.c (syms_of_cmds) <post-self-insert-hook>: Fix typos in docstring. + +2010-09-17 Jan Djärv <jan.h.d@swipnet.se> + + * gtkutil.c (xg_pack_tool_bar): Call gtk_handle_box_set_handle_position + with argument top/left if tool bar is vertical/horizontal (Bug#7051). + +2010-09-17 Kenichi Handa <handa@m17n.org> + + * ftfont.c (ftfont_check_otf): Fix previous change. + +2010-09-14 Kenichi Handa <handa@m17n.org> + + * ftfont.c (ftfont_check_otf): Fix the case of checking just + existence of GSUB or GPOS. + +2010-09-14 Juanma Barranquero <lekktu@gmail.com> + + * cmds.c (syms_of_cmds) <post-self-insert-hook>: Fix typos in docstring. + +2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * xml.c (parse_buffer): Renamed to parse_string(), since that's + what it does. + (parse_string): Return nil when the document can't be parsed. + +2010-09-14 Jan Djärv <jan.h.d@swipnet.se> + + * xterm.c (get_current_vm_state): New function. + (do_ewmh_fullscreen): Call get_current_vm_state and compare with + want_fullscreen so set_wm_state calls are few (Bug#7013). + (x_handle_net_wm_state): Move code to get_current_vm_state and + call that function. + +2010-09-14 Courtney Bane <emacs-bugs-7626@cbane.org> (tiny change) + + * term.c (tty_set_terminal_modes): Don't initialize twice (bug#7002). + +2010-09-14 Kenichi Handa <handa@m17n.org> + + * coding.c (encode_coding_iso_2022): Don't optimize for ASCII if + we may use designation or locking-shift. + +2010-09-14 Kenichi Handa <handa@m17n.org> + + * coding.c (detect_coding_emacs_mule): Fix checking of multibyte + sequence when the source is multibyte. + +2010-09-14 Andreas Schwab <schwab@linux-m68k.org> + + * xml.c (Fxml_parse_string, Fxml_parse_string): Revert last change. + Don't make first argument optional. Doc fix. + +2010-09-14 Leo <sdl.web@gmail.com> (tiny change) + + * xml.c (Fxml_parse_string, Fhtml_parse_string): Fix up the + parameters for the doc string. + +2010-09-12 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * xml.c (Fhtml_parse_string, Fxml_parse_string): Mention BASE-URL. + +2010-09-12 Stefan Monnier <monnier@iro.umontreal.ca> + + * fns.c (Fy_or_n_p): Move to lisp/subr.el. + (syms_of_fns): Don't defsubr Sy_or_n_p. + * lisp.h: Don't declare Fy_or_n_p. + * fileio.c (barf_or_query_if_file_exists): Fy_or_n_p -> y-or-n-p. + +2010-09-09 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * xml.c (Fxml_parse_buffer): New function to parse XML files. + +2010-09-08 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * xml.c: New file. + (Fhtml_parse_buffer): New function to interface to the libxml2 + html parsing function. + 2010-09-05 Juanma Barranquero <lekktu@gmail.com> * biditype.h: Regenerate. @@ -60,8 +239,8 @@ characters. * term.c (encode_terminal_code): Fix the previous change. - (produce_glyphs): Don't set it->char_to_display here. Don't - handle unibyte-display-via-language-environment here. + (produce_glyphs): Don't set it->char_to_display here. + Don't handle unibyte-display-via-language-environment here. (produce_special_glyphs): Set temp_it.char_to_display before calling produce_glyphs. @@ -80,9 +259,9 @@ (produce_stretch_glyph): Set it2.char_to_display too before calling x_produce_glyphs. (x_produce_glyphs): Simplify by using the same code for ASCII and - non-ASCII characters. Don't set it->char_to_display here. Don't - handle unibyte-display-via-language-environment here. For a - charater of no glyph, use font->space_width instead of FONT_WIDTH. + non-ASCII characters. Don't set it->char_to_display here. + Don't handle unibyte-display-via-language-environment here. For a + character of no glyph, use font->space_width instead of FONT_WIDTH. 2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca> @@ -104,7 +283,7 @@ 2010-08-29 Kenichi Handa <handa@m17n.org> * term.c (encode_terminal_code): Encode byte chars to the - correspnding bytes. + corresponding bytes. 2010-08-29 Jan Djärv <jan.h.d@swipnet.se> @@ -513,7 +692,7 @@ * xterm.c (emacs_class): New char[] for EMACS_CLASS. (xim_open_dpy, xim_initialize, xim_close_dpy): Use emacs_class. (x_term_init): Use char[] display_opt and name_opt instead of - string literal. file is const char*. + string literal. file is const char*. * xsmfns.c (NOSPLASH_OPT): Change to char[]. (smc_save_yourself_CB): Do xstrdup on all ->type and ->name for @@ -525,7 +704,7 @@ non-const char. * xmenu.c (Fx_popup_dialog): error_name is const char*. - (xmenu_show): error parameter is const char **. pane_string is const + (xmenu_show): error parameter is const char **. pane_string is const char *. (button_names): Is const char *. (xdialog_show): error_name and pane_string is const. @@ -20244,7 +20423,7 @@ * search.c (search_buffer): Give up BM search on case-fold-search if one of a target character has a case-equivalence of different - byte length even if that target charcter is an ASCII. + byte length even if that target character is an ASCII. (simple_search): Fix calculation of byte length of matched text. (boyer_moore): Fix handling of case-equivalent multibyte characters.
--- a/src/ChangeLog.10 Wed Sep 08 12:55:57 2010 +0900 +++ b/src/ChangeLog.10 Wed Sep 22 15:46:51 2010 +0900 @@ -6914,7 +6914,7 @@ * search.c (search_buffer): Give up BM search on case-fold-search if one of a target character has a case-equivalence of different - charset even if that target charcter is an ASCII. + charset even if that target character is an ASCII. * casefiddle.c (casify_object): Fix for the case that case conversion change the byte length. @@ -21089,7 +21089,7 @@ * w32.c (g_b_init_is_windows_9x, g_b_init_open_process_token) (g_b_init_get_token_information, g_b_init_lookup_account_sid) - (g_b_init_get_sid_identifier_authority ): Add several static + (g_b_init_get_sid_identifier_authority): Add several static global variables. * w32.c (globals_of_w32): New function. Used to initialize those
--- a/src/ChangeLog.8 Wed Sep 08 12:55:57 2010 +0900 +++ b/src/ChangeLog.8 Wed Sep 22 15:46:51 2010 +0900 @@ -10392,7 +10392,7 @@ * term.c (get_char_info): Use WHAT field of CHAR_INFO. Use tabs as multiples of spaces. - * dispextern.h (struct char_info ): WHAT field. + * dispextern.h (struct char_info): WHAT field. * term.c (encode_terminal_code): Don't use GLYPH_CHAR, use FAST_GLYPH_CHAR instead because GLYPH_CHAR won't remove faces. @@ -10407,8 +10407,7 @@ * xterm.c (XTget_char_info): Check WANT_ELLIPSIS_P. - * dispextern.h (struct char_info ): GLYPH_ROW for intermediate - glyphs. + * dispextern.h (struct char_info): GLYPH_ROW for intermediate glyphs. * dispnew.c (init_char_info): Init GLYPH_ROW to NULL. CHAR_CURSOR moved to xdisp.c. @@ -10436,7 +10435,7 @@ * term.c (get_char_info): Set MAX_PIXEL_WIDTH in CHAR_INFO. - * dispextern.h (struct char_info ): Use LISP_CHAR_TABLE for DP. + * dispextern.h (struct char_info): Use LISP_CHAR_TABLE for DP. New member MAX_PIXEL_HEIGHT. * xterm.c (x_per_char_metric): Get per character metrics. @@ -13869,10 +13868,10 @@ 1998-08-31 Kenichi Handa <handa@etl.go.jp> * charset.c (unibyte_char_to_multibyte): - Vnonacii_translation_table will convert a 7-bit charcater. + Vnonacii_translation_table will convert a 7-bit character. (multibyte_char_to_unibyte): Handle the case that - Vnonacii_translation_table converts a multibyte charcater to a - unibyte charcter of less than 128. + Vnonacii_translation_table converts a multibyte character to a + unibyte character of less than 128. (init_charset_once): Initialize nonascii_insert_offset and Vnonacii_translation_table.
--- a/src/Makefile.in Wed Sep 08 12:55:57 2010 +0900 +++ b/src/Makefile.in Wed Sep 22 15:46:51 2010 +0900 @@ -35,6 +35,7 @@ CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ +LD_FIRSTFLAG=@LD_FIRSTFLAG@ EXEEXT = @EXEEXT@ version = @version@ # Substitute an assignment for the MAKE variable, because @@ -124,8 +125,6 @@ ## Where to find libgcc.a, if using gcc and necessary. LIB_GCC=@LIB_GCC@ -LD=@LINKER@ - ## May use $CRT_DIR. LIB_STANDARD=@LIB_STANDARD@ @@ -226,6 +225,8 @@ IMAGEMAGICK_LIBS= @IMAGEMAGICK_LIBS@ IMAGEMAGICK_CFLAGS= @IMAGEMAGICK_CFLAGS@ +LIBXML2_LIBS = @LIBXML2_LIBS@ +LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ ## widget.o if USE_X_TOOLKIT, otherwise empty. WIDGET_OBJ=@WIDGET_OBJ@ @@ -320,7 +321,8 @@ ## FIXME? MYCPPFLAGS only referenced in etc/DEBUG. ALL_CFLAGS=-Demacs -DHAVE_CONFIG_H $(MYCPPFLAGS) -I. -I${srcdir} \ ${C_SWITCH_MACHINE} ${C_SWITCH_SYSTEM} ${C_SWITCH_X_SITE} \ - ${C_SWITCH_X_SYSTEM} ${CFLAGS_SOUND} ${RSVG_CFLAGS} ${IMAGEMAGICK_CFLAGS} ${DBUS_CFLAGS} \ + ${C_SWITCH_X_SYSTEM} ${CFLAGS_SOUND} ${RSVG_CFLAGS} ${IMAGEMAGICK_CFLAGS} \ + ${LIBXML2_CFLAGS} ${DBUS_CFLAGS} \ ${GCONF_CFLAGS} ${FREETYPE_CFLAGS} ${FONTCONFIG_CFLAGS} \ ${LIBOTF_CFLAGS} ${M17N_FLT_CFLAGS} ${DEPFLAGS} ${PROFILING_CFLAGS} \ ${C_WARNINGS_SWITCH} ${CFLAGS} @@ -349,7 +351,7 @@ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o callproc.o \ region-cache.o sound.o atimer.o \ - doprnt.o strftime.o intervals.o textprop.o composite.o md5.o \ + doprnt.o strftime.o intervals.o textprop.o composite.o md5.o xml.o \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) ## Object files used on some machine or other. @@ -595,7 +597,8 @@ ## duplicated symbols. If the standard libraries were compiled ## with GCC, we might need LIB_GCC again after them. LIBES = $(LIBS) $(LIBX_BASE) $(LIBX_OTHER) $(LIBSOUND) \ - $(RSVG_LIBS) ${IMAGEMAGICK_LIBS} $(DBUS_LIBS) $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) \ + $(RSVG_LIBS) ${IMAGEMAGICK_LIBS} $(DBUS_LIBS) \ + ${LIBXML2_LIBS} $(LIBGPM) $(LIBRESOLV) $(LIBS_SYSTEM) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) ${GCONF_LIBS} ${LIBSELINUX_LIBS} \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIB_GCC) $(LIB_MATH) $(LIB_STANDARD) $(LIB_GCC) @@ -642,7 +645,7 @@ temacs${EXEEXT}: $(START_FILES) stamp-oldxmenu ${obj} ${otherobj} - $(LD) ${TEMACS_LDFLAGS} ${TEMACS_LDFLAGS2} \ + $(CC) $(LD_FIRSTFLAG) ${TEMACS_LDFLAGS} ${TEMACS_LDFLAGS2} \ -o temacs ${START_FILES} ${obj} ${otherobj} ${LIBES} ## The following oldxmenu-related rules are only (possibly) used if
--- a/src/bidi.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/bidi.c Wed Sep 22 15:46:51 2010 +0900 @@ -583,18 +583,26 @@ return pos_byte; } -/* Determine the direction, a.k.a. base embedding level, of the +/* Determine the base direction, a.k.a. base embedding level, of the paragraph we are about to iterate through. If DIR is either L2R or R2L, just use that. Otherwise, determine the paragraph direction - from the first strong character of the paragraph. + from the first strong directional character of the paragraph. - Note that this gives the paragraph separator the same direction as - the preceding paragraph, even though Emacs generally views the - separartor as not belonging to any paragraph. */ + NO_DEFAULT_P non-nil means don't default to L2R if the paragraph + has no strong directional characters and both DIR and + bidi_it->paragraph_dir are NEUTRAL_DIR. In that case, search back + in the buffer until a paragraph is found with a strong character, + or until hitting BEGV. In the latter case, fall back to L2R. This + flag is used in current-bidi-paragraph-direction. + + Note that this function gives the paragraph separator the same + direction as the preceding paragraph, even though Emacs generally + views the separartor as not belonging to any paragraph. */ void -bidi_paragraph_init (bidi_dir_t dir, struct bidi_it *bidi_it) +bidi_paragraph_init (bidi_dir_t dir, struct bidi_it *bidi_it, int no_default_p) { EMACS_INT bytepos = bidi_it->bytepos; + EMACS_INT pstartbyte; /* Special case for an empty buffer. */ if (bytepos == BEGV_BYTE && bytepos == ZV_BYTE) @@ -643,49 +651,75 @@ /* We are either at the beginning of a paragraph or in the middle of it. Find where this paragraph starts. */ - bytepos = bidi_find_paragraph_start (pos, bytepos); - + pstartbyte = bidi_find_paragraph_start (pos, bytepos); bidi_it->separator_limit = -1; bidi_it->new_paragraph = 0; - ch = FETCH_CHAR (bytepos); - ch_len = CHAR_BYTES (ch); - pos = BYTE_TO_CHAR (bytepos); - type = bidi_get_type (ch, NEUTRAL_DIR); + + /* The following loop is run more than once only if NO_DEFAULT_P + is non-zero. */ + do { + bytepos = pstartbyte; + ch = FETCH_CHAR (bytepos); + ch_len = CHAR_BYTES (ch); + pos = BYTE_TO_CHAR (bytepos); + type = bidi_get_type (ch, NEUTRAL_DIR); - for (pos++, bytepos += ch_len; - /* NOTE: UAX#9 says to search only for L, AL, or R types of - characters, and ignore RLE, RLO, LRE, and LRO. However, - I'm not sure it makes sense to omit those 4; should try - with and without that to see the effect. */ - (bidi_get_category (type) != STRONG) - || (bidi_ignore_explicit_marks_for_paragraph_level - && (type == RLE || type == RLO - || type == LRE || type == LRO)); - type = bidi_get_type (ch, NEUTRAL_DIR)) - { - if (type == NEUTRAL_B && bidi_at_paragraph_end (pos, bytepos) >= -1) - break; - if (bytepos >= ZV_BYTE) - { - /* Pretend there's a paragraph separator at end of buffer. */ - type = NEUTRAL_B; + for (pos++, bytepos += ch_len; + /* NOTE: UAX#9 says to search only for L, AL, or R types + of characters, and ignore RLE, RLO, LRE, and LRO. + However, I'm not sure it makes sense to omit those 4; + should try with and without that to see the effect. */ + (bidi_get_category (type) != STRONG) + || (bidi_ignore_explicit_marks_for_paragraph_level + && (type == RLE || type == RLO + || type == LRE || type == LRO)); + type = bidi_get_type (ch, NEUTRAL_DIR)) + { + if (type == NEUTRAL_B && bidi_at_paragraph_end (pos, bytepos) >= -1) break; - } - FETCH_CHAR_ADVANCE (ch, pos, bytepos); - } - if (type == STRONG_R || type == STRONG_AL) /* P3 */ - bidi_it->paragraph_dir = R2L; - else if (type == STRONG_L) - bidi_it->paragraph_dir = L2R; + if (bytepos >= ZV_BYTE) + { + /* Pretend there's a paragraph separator at end of + buffer. */ + type = NEUTRAL_B; + break; + } + FETCH_CHAR_ADVANCE (ch, pos, bytepos); + } + if (type == STRONG_R || type == STRONG_AL) /* P3 */ + bidi_it->paragraph_dir = R2L; + else if (type == STRONG_L) + bidi_it->paragraph_dir = L2R; + if (no_default_p && bidi_it->paragraph_dir == NEUTRAL_DIR) + { + /* If this paragraph is at BEGV, default to L2R. */ + if (pstartbyte == BEGV_BYTE) + bidi_it->paragraph_dir = L2R; /* P3 and HL1 */ + else + { + EMACS_INT prevpbyte = pstartbyte; + EMACS_INT p = BYTE_TO_CHAR (pstartbyte), pbyte = pstartbyte; + + /* Find the beginning of the previous paragraph, if any. */ + while (pbyte > BEGV_BYTE && prevpbyte >= pstartbyte) + { + p--; + pbyte = CHAR_TO_BYTE (p); + prevpbyte = bidi_find_paragraph_start (p, pbyte); + } + pstartbyte = prevpbyte; + } + } + } while (no_default_p && bidi_it->paragraph_dir == NEUTRAL_DIR); } else abort (); /* Contrary to UAX#9 clause P3, we only default the paragraph direction to L2R if we have no previous usable paragraph - direction. */ + direction. This is allowed by the HL1 clause. */ if (bidi_it->paragraph_dir != L2R && bidi_it->paragraph_dir != R2L) - bidi_it->paragraph_dir = L2R; /* P3 and ``higher protocols'' */ + bidi_it->paragraph_dir = L2R; /* P3 and HL1 ``higher-level protocols'' */ if (bidi_it->paragraph_dir == R2L) bidi_it->level_stack[0].level = 1; else
--- a/src/buffer.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/buffer.c Wed Sep 22 15:46:51 2010 +0900 @@ -2345,7 +2345,7 @@ { c = STRING_CHAR_AND_LENGTH (p, bytes); /* Delete all bytes for this 8-bit character but the - last one, and change the last one to the charcter + last one, and change the last one to the character code. */ bytes--; del_range_2 (pos, pos, pos + bytes, pos + bytes, 0);
--- a/src/charset.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/charset.c Wed Sep 22 15:46:51 2010 +0900 @@ -427,7 +427,7 @@ /* Read a hexadecimal number (preceded by "0x") from the file FP while - paying attention to comment charcter '#'. */ + paying attention to comment character '#'. */ static INLINE unsigned read_hex (FILE *fp, int *eof)
--- a/src/cmds.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/cmds.c Wed Sep 22 15:46:51 2010 +0900 @@ -524,7 +524,7 @@ DEFVAR_LISP ("post-self-insert-hook", &Vpost_self_insert_hook, doc: /* Hook run at the end of `self-insert-command'. -This run is run after inserting the charater. */); +This is run after inserting the character. */); Vpost_self_insert_hook = Qnil; defsubr (&Sforward_point);
--- a/src/coding.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/coding.c Wed Sep 22 15:46:51 2010 +0900 @@ -2008,7 +2008,7 @@ } else { - int more_bytes = emacs_mule_bytes[*src_base] - 1; + int more_bytes = emacs_mule_bytes[c] - 1; while (more_bytes > 0) { @@ -4490,7 +4490,10 @@ charset_list = CODING_ATTR_CHARSET_LIST (attrs); coding->safe_charsets = SDATA (CODING_ATTR_SAFE_CHARSETS (attrs)); - ascii_compatible = ! NILP (CODING_ATTR_ASCII_COMPAT (attrs)); + ascii_compatible + = (! NILP (CODING_ATTR_ASCII_COMPAT (attrs)) + && ! (CODING_ISO_FLAGS (coding) & (CODING_ISO_FLAG_DESIGNATION + | CODING_ISO_FLAG_LOCKING_SHIFT))); while (charbuf < charbuf_end) {
--- a/src/config.in Wed Sep 08 12:55:57 2010 +0900 +++ b/src/config.in Wed Sep 22 15:46:51 2010 +0900 @@ -813,6 +813,9 @@ /* Define to 1 if you have the SM library (-lSM). */ #undef HAVE_X_SM +/* Define to 1 if you have the libxml2 library (-lxml2). */ +#undef HAVE_LIBXML2 + /* Define to 1 if you want to use the X window system. */ #undef HAVE_X_WINDOWS
--- a/src/deps.mk Wed Sep 08 12:55:57 2010 +0900 +++ b/src/deps.mk Wed Sep 22 15:46:51 2010 +0900 @@ -230,6 +230,7 @@ charset.h keyboard.h $(srcdir)/../lwlib/lwlib.h blockinput.h atimer.h \ systime.h gtkutil.h msdos.h coding.h menu.h lisp.h $(config_h) composite.h \ keymap.h sysselect.h +xml.o: xml.c buffer.h lisp.h $(config_h) xterm.o: xterm.c xterm.h termhooks.h termopts.h termchar.h window.h buffer.h \ dispextern.h frame.h disptab.h blockinput.h atimer.h systime.h syssignal.h \ keyboard.h emacs-icon.h character.h charset.h ccl.h fontset.h composite.h \
--- a/src/dispextern.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/dispextern.h Wed Sep 22 15:46:51 2010 +0900 @@ -2896,7 +2896,7 @@ extern void bidi_init_it (EMACS_INT, EMACS_INT, struct bidi_it *); extern void bidi_move_to_visually_next (struct bidi_it *); -extern void bidi_paragraph_init (bidi_dir_t, struct bidi_it *); +extern void bidi_paragraph_init (bidi_dir_t, struct bidi_it *, int); extern int bidi_mirror_char (int); /* Defined in xdisp.c */
--- a/src/dispnew.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/dispnew.c Wed Sep 22 15:46:51 2010 +0900 @@ -5420,6 +5420,22 @@ if (STRINGP (it.string)) string = it.string; *pos = it.current; + if (it.what == IT_COMPOSITION + && it.cmp_it.nchars > 1 + && it.cmp_it.reversed_p) + { + /* The current display element is a grapheme cluster in a + composition. In that case, we need the position of the first + character of the cluster. But, as it.cmp_it.reversed_p is 1, + it.current points to the last character of the cluster, thus + we must move back to the first character of the same + cluster. */ + CHARPOS (pos->pos) -= it.cmp_it.nchars - 1; + if (STRINGP (it.string)) + BYTEPOS (pos->pos) = string_char_to_byte (string, CHARPOS (pos->pos)); + else + BYTEPOS (pos->pos) = CHAR_TO_BYTE (CHARPOS (pos->pos)); + } #ifdef HAVE_WINDOW_SYSTEM if (it.what == IT_IMAGE)
--- a/src/doc.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/doc.c Wed Sep 22 15:46:51 2010 +0900 @@ -678,7 +678,7 @@ } pos += end - buf; filled -= end - buf; - memcpy (buf, end, filled); + memmove (buf, end, filled); } emacs_close (fd); return Qnil;
--- a/src/doprnt.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/doprnt.c Wed Sep 22 15:46:51 2010 +0900 @@ -33,21 +33,17 @@ #include <unistd.h> #endif -#ifdef HAVE_STDLIB_H -#include <stdlib.h> -#endif - #include "lisp.h" -#ifndef DBL_MAX_10_EXP -#define DBL_MAX_10_EXP 308 /* IEEE double */ -#endif - /* Since we use the macro CHAR_HEAD_P, we have to include this, but don't have to include others because CHAR_HEAD_P does not contains another macro. */ #include "character.h" +#ifndef DBL_MAX_10_EXP +#define DBL_MAX_10_EXP 308 /* IEEE double */ +#endif + /* Generate output from a format-spec FORMAT, terminated at position FORMAT_END. Output goes in BUFFER, which has room for BUFSIZE chars.
--- a/src/editfns.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/editfns.c Wed Sep 22 15:46:51 2010 +0900 @@ -3517,7 +3517,7 @@ int multibyte = 0; /* When we make a multibyte string, we must pay attention to the byte combining problem, i.e., a byte may be combined with a - multibyte charcter of the previous string. This flag tells if we + multibyte character of the previous string. This flag tells if we must consider such a situation or not. */ int maybe_combine_byte; unsigned char *this_format;
--- a/src/emacs.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/emacs.c Wed Sep 22 15:46:51 2010 +0900 @@ -32,10 +32,6 @@ #include <unistd.h> #endif -#ifdef HAVE_SYS_IOCTL_H -#include <sys/ioctl.h> -#endif - #ifdef WINDOWSNT #include <fcntl.h> #include <windows.h> /* just for w32.h */ @@ -1544,6 +1540,10 @@ #endif #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_LIBXML2 + syms_of_xml (); +#endif + syms_of_menu (); #ifdef HAVE_NTGUI
--- a/src/fileio.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/fileio.c Wed Sep 22 15:46:51 2010 +0900 @@ -1842,7 +1842,7 @@ tem = format2 ("File %s already exists; %s anyway? ", absname, build_string (querystring)); if (quick) - tem = Fy_or_n_p (tem); + tem = call1 (intern ("y-or-n-p"), tem); else tem = do_yes_or_no_p (tem); UNGCPRO;
--- a/src/fns.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/fns.c Wed Sep 22 15:46:51 2010 +0900 @@ -2444,146 +2444,6 @@ return sequence; } -/* Anything that calls this function must protect from GC! */ - -DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0, - doc: /* Ask user a "y or n" question. Return t if answer is "y". -Takes one argument, which is the string to display to ask the question. -It should end in a space; `y-or-n-p' adds `(y or n) ' to it. -No confirmation of the answer is requested; a single character is enough. -Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses -the bindings in `query-replace-map'; see the documentation of that variable -for more information. In this case, the useful bindings are `act', `skip', -`recenter', and `quit'.\) - -Under a windowing system a dialog box will be used if `last-nonmenu-event' -is nil and `use-dialog-box' is non-nil. */) - (Lisp_Object prompt) -{ - register Lisp_Object obj, key, def, map; - register int answer; - Lisp_Object xprompt; - Lisp_Object args[2]; - struct gcpro gcpro1, gcpro2; - int count = SPECPDL_INDEX (); - - specbind (Qcursor_in_echo_area, Qt); - - map = Fsymbol_value (intern ("query-replace-map")); - - CHECK_STRING (prompt); - xprompt = prompt; - GCPRO2 (prompt, xprompt); - -#ifdef HAVE_WINDOW_SYSTEM - if (display_hourglass_p) - cancel_hourglass (); -#endif - - while (1) - { - -#ifdef HAVE_MENUS - if (FRAME_WINDOW_P (SELECTED_FRAME ()) - && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) - && use_dialog_box - && have_menus_p ()) - { - Lisp_Object pane, menu; - redisplay_preserve_echo_area (3); - pane = Fcons (Fcons (build_string ("Yes"), Qt), - Fcons (Fcons (build_string ("No"), Qnil), - Qnil)); - menu = Fcons (prompt, pane); - obj = Fx_popup_dialog (Qt, menu, Qnil); - answer = !NILP (obj); - break; - } -#endif /* HAVE_MENUS */ - cursor_in_echo_area = 1; - choose_minibuf_frame (); - - { - Lisp_Object pargs[3]; - - /* Colorize prompt according to `minibuffer-prompt' face. */ - pargs[0] = build_string ("%s(y or n) "); - pargs[1] = intern ("face"); - pargs[2] = intern ("minibuffer-prompt"); - args[0] = Fpropertize (3, pargs); - args[1] = xprompt; - Fmessage (2, args); - } - - if (minibuffer_auto_raise) - { - Lisp_Object mini_frame; - - mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window)); - - Fraise_frame (mini_frame); - } - - temporarily_switch_to_single_kboard (SELECTED_FRAME ()); - obj = read_filtered_event (1, 0, 0, 0, Qnil); - cursor_in_echo_area = 0; - /* If we need to quit, quit with cursor_in_echo_area = 0. */ - QUIT; - - key = Fmake_vector (make_number (1), obj); - def = Flookup_key (map, key, Qt); - - if (EQ (def, intern ("skip"))) - { - answer = 0; - break; - } - else if (EQ (def, intern ("act"))) - { - answer = 1; - break; - } - else if (EQ (def, intern ("recenter"))) - { - Frecenter (Qnil); - xprompt = prompt; - continue; - } - else if (EQ (def, intern ("quit"))) - Vquit_flag = Qt; - /* We want to exit this command for exit-prefix, - and this is the only way to do it. */ - else if (EQ (def, intern ("exit-prefix"))) - Vquit_flag = Qt; - - QUIT; - - /* If we don't clear this, then the next call to read_char will - return quit_char again, and we'll enter an infinite loop. */ - Vquit_flag = Qnil; - - Fding (Qnil); - Fdiscard_input (); - if (EQ (xprompt, prompt)) - { - args[0] = build_string ("Please answer y or n. "); - args[1] = prompt; - xprompt = Fconcat (2, args); - } - } - UNGCPRO; - - if (! noninteractive) - { - cursor_in_echo_area = -1; - message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n", - xprompt, 0); - } - - unbind_to (count, Qnil); - return answer ? Qt : Qnil; -} - /* This is how C code calls `yes-or-no-p' and allows the user to redefined it. @@ -5058,7 +4918,6 @@ defsubr (&Smapcar); defsubr (&Smapc); defsubr (&Smapconcat); - defsubr (&Sy_or_n_p); defsubr (&Syes_or_no_p); defsubr (&Sload_average); defsubr (&Sfeaturep);
--- a/src/frame.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/frame.c Wed Sep 22 15:46:51 2010 +0900 @@ -2649,6 +2649,28 @@ #endif return make_number (FRAME_COLS (f)); } + +DEFUN ("tool-bar-pixel-width", Ftool_bar_pixel_width, + Stool_bar_pixel_width, 0, 1, 0, + doc: /* Return width in pixels of FRAME's tool bar. +The result is greater than zero only when the tool bar is on the left +or right side of FRAME. If FRAME is omitted, the selected frame is +used. */) + (Lisp_Object frame) +{ + struct frame *f; + + if (NILP (frame)) + frame = selected_frame; + CHECK_FRAME (frame); + f = XFRAME (frame); + +#ifdef FRAME_TOOLBAR_WIDTH + if (FRAME_WINDOW_P (f)) + return make_number (FRAME_TOOLBAR_WIDTH (f)); +#endif + return make_number (0); +} DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 3, 0, doc: /* Specify that the frame FRAME has LINES lines. @@ -4596,6 +4618,7 @@ defsubr (&Sframe_char_width); defsubr (&Sframe_pixel_height); defsubr (&Sframe_pixel_width); + defsubr (&Stool_bar_pixel_width); defsubr (&Sset_frame_height); defsubr (&Sset_frame_width); defsubr (&Sset_frame_size);
--- a/src/ftfont.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/ftfont.c Wed Sep 22 15:46:51 2010 +0900 @@ -1632,38 +1632,70 @@ static int ftfont_check_otf (MFLTFont *font, MFLTOtfSpec *spec) { +#define FEATURE_NONE(IDX) (! spec->features[IDX]) + +#define FEATURE_ANY(IDX) \ + (spec->features[IDX] \ + && spec->features[IDX][0] == 0xFFFFFFFF && spec->features[IDX][1] == 0) + struct MFLTFontFT *flt_font_ft = (struct MFLTFontFT *) font; OTF *otf = flt_font_ft->otf; OTF_Tag *tags; int i, n, negative; + if (FEATURE_ANY (0) && FEATURE_ANY (1)) + /* Return 1 iff any of GSUB or GPOS support the script (and language). */ + return (otf + && (OTF_check_features (otf, 0, spec->script, spec->langsys, + NULL, 0) > 0 + || OTF_check_features (otf, 1, spec->script, spec->langsys, + NULL, 0) > 0)); + for (i = 0; i < 2; i++) - { - if (! spec->features[i]) - continue; - for (n = 0; spec->features[i][n]; n++); - tags = alloca (sizeof (OTF_Tag) * n); - for (n = 0, negative = 0; spec->features[i][n]; n++) - { - if (spec->features[i][n] == 0xFFFFFFFF) - negative = 1; - else if (negative) - tags[n - 1] = spec->features[i][n] | 0x80000000; - else - tags[n] = spec->features[i][n]; - } + if (! FEATURE_ANY (i)) + { + if (FEATURE_NONE (i)) + { + if (otf + && OTF_check_features (otf, i == 0, spec->script, spec->langsys, + NULL, 0) > 0) + return 0; + continue; + } + if (spec->features[i][0] == 0xFFFFFFFF) + { + if (! otf + || OTF_check_features (otf, i == 0, spec->script, spec->langsys, + NULL, 0) <= 0) + continue; + } + else if (! otf) + return 0; + for (n = 1; spec->features[i][n]; n++); + tags = alloca (sizeof (OTF_Tag) * n); + for (n = 0, negative = 0; spec->features[i][n]; n++) + { + if (spec->features[i][n] == 0xFFFFFFFF) + negative = 1; + else if (negative) + tags[n - 1] = spec->features[i][n] | 0x80000000; + else + tags[n] = spec->features[i][n]; + } #ifdef M17N_FLT_USE_NEW_FEATURE - if (OTF_check_features (otf, i == 0, spec->script, spec->langsys, - tags, n - negative) != 1) - return 0; + if (OTF_check_features (otf, i == 0, spec->script, spec->langsys, + tags, n - negative) != 1) + return 0; #else /* not M17N_FLT_USE_NEW_FEATURE */ - if (n - negative > 0 - && OTF_check_features (otf, i == 0, spec->script, spec->langsys, - tags, n - negative) != 1) - return 0; + if (n - negative > 0 + && OTF_check_features (otf, i == 0, spec->script, spec->langsys, + tags, n - negative) != 1) + return 0; #endif /* not M17N_FLT_USE_NEW_FEATURE */ - } + } return 1; +#undef FEATURE_NONE +#undef FEATURE_ANY } #define DEVICE_DELTA(table, size) \
--- a/src/gtkutil.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/gtkutil.c Wed Sep 22 15:46:51 2010 +0900 @@ -3974,6 +3974,8 @@ if (into_hbox) { + gtk_handle_box_set_handle_position (GTK_HANDLE_BOX (x->handlebox_widget), + GTK_POS_TOP); gtk_box_pack_start (GTK_BOX (x->hbox_widget), x->handlebox_widget, FALSE, FALSE, 0); @@ -3986,6 +3988,8 @@ else { int vbox_pos = x->menubar_widget ? 1 : 0; + gtk_handle_box_set_handle_position (GTK_HANDLE_BOX (x->handlebox_widget), + GTK_POS_LEFT); gtk_box_pack_start (GTK_BOX (x->vbox_widget), x->handlebox_widget, FALSE, FALSE, 0);
--- a/src/keyboard.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/keyboard.c Wed Sep 22 15:46:51 2010 +0900 @@ -8305,7 +8305,7 @@ { const char *bad_label = "!!?GARBLED ITEM?!!"; /* `:label LABEL-STRING'. */ - PROP (TOOL_BAR_ITEM_HELP) = STRINGP (value) + PROP (TOOL_BAR_ITEM_LABEL) = STRINGP (value) ? value : make_string (bad_label, strlen (bad_label)); have_label = 1;
--- a/src/lisp.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/lisp.h Wed Sep 22 15:46:51 2010 +0900 @@ -2516,7 +2516,6 @@ EXFUN (Fnconc, MANY); EXFUN (Fmapcar, 2); EXFUN (Fmapconcat, 3); -EXFUN (Fy_or_n_p, 1); extern Lisp_Object do_yes_or_no_p (Lisp_Object); EXFUN (Frequire, 3); EXFUN (Fprovide, 2); @@ -3577,6 +3576,11 @@ EXFUN (Fmsdos_downcase_filename, 1); #endif +#ifdef HAVE_LIBXML2 +/* Defined in xml.c */ +extern void syms_of_xml (void); +#endif + #ifdef HAVE_MENUS /* Defined in (x|w32)fns.c, nsfns.m... */ extern int have_menus_p (void);
--- a/src/makefile.w32-in Wed Sep 08 12:55:57 2010 +0900 +++ b/src/makefile.w32-in Wed Sep 22 15:46:51 2010 +0900 @@ -1344,7 +1344,6 @@ $(EMACS_ROOT)/nt/inc/pwd.h \ $(EMACS_ROOT)/nt/inc/unistd.h \ $(EMACS_ROOT)/nt/inc/sys/file.h \ - $(EMACS_ROOT)/nt/inc/sys/ioctl.h \ $(EMACS_ROOT)/nt/inc/sys/socket.h \ $(EMACS_ROOT)/nt/inc/sys/time.h \ $(SRC)/lisp.h \
--- a/src/process.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/process.c Wed Sep 22 15:46:51 2010 +0900 @@ -4403,7 +4403,7 @@ FD_ZERO (&Connecting); #endif - if (time_limit == 0 && wait_proc && !NILP (Vinhibit_quit) + if (time_limit == 0 && microsecs == 0 && wait_proc && !NILP (Vinhibit_quit) && !(CONSP (wait_proc->status) && EQ (XCAR (wait_proc->status), Qexit))) message ("Blocking call to accept-process-output with quit inhibited!!");
--- a/src/s/aix4-2.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/aix4-2.h Wed Sep 22 15:46:51 2010 +0900 @@ -37,10 +37,6 @@ #define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptc"); #define PTY_TTY_NAME_SPRINTF strcpy (pty_name, ttyname (fd)); -/* Define HAVE_TERMIO if the system provides sysV-style ioctls - for terminal control. */ -#define HAVE_TERMIOS - /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS
--- a/src/s/bsd-common.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/bsd-common.h Wed Sep 22 15:46:51 2010 +0900 @@ -42,7 +42,6 @@ #undef KERNEL_FILE #undef LDAV_SYMBOL -#define HAVE_TERMIOS #define NO_TERMIO /* If the system's imake configuration file defines `NeedWidePrototypes'
--- a/src/s/cygwin.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/cygwin.h Wed Sep 22 15:46:51 2010 +0900 @@ -45,16 +45,6 @@ through a pipe. */ #undef INTERRUPT_INPUT -/* Define HAVE_TERMIOS if the system provides POSIX-style - functions and macros for terminal control. - - Define HAVE_TERMIO if the system provides sysV-style ioctls - for terminal control. - - Do not define both. HAVE_TERMIOS is preferred, if it is - supported on your system. */ -#define HAVE_TERMIOS - /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS #define PTY_ITERATION for (i = 0; i < 1; i++) /* ick */
--- a/src/s/darwin.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/darwin.h Wed Sep 22 15:46:51 2010 +0900 @@ -63,15 +63,6 @@ if system supports pty's. 'a' means it is /dev/ptya0 */ #define FIRST_PTY_LETTER 'p' -/* Define HAVE_TERMIOS if the system provides POSIX-style - functions and macros for terminal control. - - Define HAVE_TERMIO if the system provides sysV-style ioctls - for terminal control. - - Do not define both. HAVE_TERMIOS is preferred, if it is supported - on your system. */ -#define HAVE_TERMIOS #define NO_TERMIO /* Define HAVE_PTYS if the system supports pty devices.
--- a/src/s/gnu-linux.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/gnu-linux.h Wed Sep 22 15:46:51 2010 +0900 @@ -80,10 +80,6 @@ #endif /* not HAVE_GRANTPT */ -/* Define HAVE_TERMIOS if the system provides POSIX-style - functions and macros for terminal control. */ -#define HAVE_TERMIOS - /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS
--- a/src/s/hpux10-20.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/hpux10-20.h Wed Sep 22 15:46:51 2010 +0900 @@ -35,11 +35,8 @@ if system supports pty's. 'p' means it is /dev/ptym/ptyp0 */ #define FIRST_PTY_LETTER 'p' -#define HAVE_TERMIOS #define NO_TERMIO -#define ORDINARY_LINK - /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS @@ -78,9 +75,6 @@ HP-UX 10.20, and that it works for HP-UX 0 as well. */ #define NO_EDITRES -/* Tested in getloadavg.c. */ -#define HAVE_PSTAT_GETDYNAMIC - /* Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines has a broken `rint' in some library versions including math library version number A.09.05.
--- a/src/s/template.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/template.h Wed Sep 22 15:46:51 2010 +0900 @@ -63,18 +63,6 @@ if system supports pty's. 'a' means it is /dev/ptya0. */ #define FIRST_PTY_LETTER 'a' -/* Define HAVE_TERMIOS if the system provides POSIX-style - functions and macros for terminal control. - - Define HAVE_TERMIO if the system provides sysV-style ioctls - for terminal control. - - Do not define both. HAVE_TERMIOS is preferred, if it is - supported on your system. */ - -#define HAVE_TERMIOS -/* #define HAVE_TERMIO */ - /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS
--- a/src/s/usg5-4-common.h Wed Sep 08 12:55:57 2010 +0900 +++ b/src/s/usg5-4-common.h Wed Sep 22 15:46:51 2010 +0900 @@ -31,10 +31,6 @@ It sets the Lisp variable system-type. */ #define SYSTEM_TYPE "usg-unix-v" -/* Define HAVE_TERMIO if the system provides sysV-style ioctls - for terminal control. */ -#define HAVE_TERMIO - /* The file containing the kernel's symbol table is called /unix. */ #define KERNEL_FILE "/unix" @@ -78,7 +74,6 @@ /* Define HAVE_PTYS if the system supports pty devices. */ #define HAVE_PTYS -#define HAVE_TERMIOS /* It is possible to receive SIGCHLD when there are no children waiting, because a previous waitsys(2) cleaned up the carcass of child
--- a/src/term.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/term.c Wed Sep 22 15:46:51 2010 +0900 @@ -247,7 +247,6 @@ cmputc ('\n'); } - OUTPUT_IF (tty, tty->TS_termcap_modes); OUTPUT_IF (tty, visible_cursor ? tty->TS_cursor_visible : tty->TS_cursor_normal); OUTPUT_IF (tty, tty->TS_keypad_mode); losecursor (tty);
--- a/src/w32.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/w32.c Wed Sep 22 15:46:51 2010 +0900 @@ -94,8 +94,11 @@ #include <tlhelp32.h> #include <psapi.h> +#include <w32api.h> +#if !defined(__MINGW32__) || __W32API_MAJOR_VERSION < 3 || (__W32API_MAJOR_VERSION == 3 && __W32API_MINOR_VERSION < 15) /* This either is not in psapi.h or guarded by higher value of - _WIN32_WINNT than what we use. */ + _WIN32_WINNT than what we use. w32api suplied with MinGW 3.15 + defines it in psapi.h */ typedef struct _PROCESS_MEMORY_COUNTERS_EX { DWORD cb; DWORD PageFaultCount; @@ -109,8 +112,9 @@ DWORD PeakPagefileUsage; DWORD PrivateUsage; } PROCESS_MEMORY_COUNTERS_EX,*PPROCESS_MEMORY_COUNTERS_EX; - -#ifdef HAVE_SOCKETS /* TCP connection support, if kernel can do it */ +#endif + +/* TCP connection support. */ #include <sys/socket.h> #undef socket #undef bind @@ -129,7 +133,6 @@ #undef accept #undef recvfrom #undef sendto -#endif #include "w32.h" #include "ndir.h" @@ -830,17 +833,6 @@ #endif } -#ifndef HAVE_SOCKETS -/* Emulate gethostname. */ -int -gethostname (char *buffer, int size) -{ - /* NT only allows small host names, so the buffer is - certainly large enough. */ - return !GetComputerName (buffer, &size); -} -#endif /* HAVE_SOCKETS */ - /* Emulate getloadavg. */ struct load_sample { @@ -4348,8 +4340,6 @@ } -#ifdef HAVE_SOCKETS - /* Wrappers for winsock functions to map between our file descriptors and winsock's handles; also set h_errno for convenience. @@ -4636,13 +4626,7 @@ but I believe the method of keeping the socket handle separate (and insuring it is not inheritable) is the correct one. */ -//#define SOCK_REPLACE_HANDLE - -#ifdef SOCK_REPLACE_HANDLE -#define SOCK_HANDLE(fd) ((SOCKET) _get_osfhandle (fd)) -#else #define SOCK_HANDLE(fd) ((SOCKET) fd_info[fd].hnd) -#endif int socket_to_fd (SOCKET s); @@ -4686,13 +4670,6 @@ fd = _open ("NUL:", _O_RDWR); if (fd >= 0) { -#ifdef SOCK_REPLACE_HANDLE - /* now replace handle to NUL with our socket handle */ - CloseHandle ((HANDLE) _get_osfhandle (fd)); - _free_osfhnd (fd); - _set_osfhnd (fd, s); - /* setmode (fd, _O_BINARY); */ -#else /* Make a non-inheritable copy of the socket handle. Note that it is possible that sockets aren't actually kernel handles, which appears to be the case on Windows 9x when @@ -4738,7 +4715,6 @@ } } fd_info[fd].hnd = (HANDLE) s; -#endif /* set our own internal flags */ fd_info[fd].flags = FILE_SOCKET | FILE_BINARY | FILE_READ | FILE_WRITE; @@ -5099,8 +5075,6 @@ return SOCKET_ERROR; } -#endif /* HAVE_SOCKETS */ - /* Shadow main io functions: we need to handle pipes and sockets more intelligently, and implement non-blocking mode as well. */ @@ -5135,18 +5109,15 @@ } if (i == MAXDESC) { -#ifdef HAVE_SOCKETS if (fd_info[fd].flags & FILE_SOCKET) { -#ifndef SOCK_REPLACE_HANDLE if (winsock_lib == NULL) abort (); pfn_shutdown (SOCK_HANDLE (fd), 2); rc = pfn_closesocket (SOCK_HANDLE (fd)); -#endif + winsock_inuse--; /* count open sockets */ } -#endif delete_child (cp); } } @@ -5314,7 +5285,6 @@ return STATUS_READ_ERROR; } } -#ifdef HAVE_SOCKETS else if (fd_info[fd].flags & FILE_SOCKET) { unsigned long nblock = 0; @@ -5330,7 +5300,6 @@ pfn_ioctlsocket (SOCK_HANDLE (fd), FIONBIO, &nblock); } } -#endif if (rc == sizeof (char)) cp->status = STATUS_READ_SUCCEEDED; @@ -5502,7 +5471,6 @@ nchars += rc; } } -#ifdef HAVE_SOCKETS else /* FILE_SOCKET */ { if (winsock_lib == NULL) abort (); @@ -5529,7 +5497,6 @@ nchars += res; } } -#endif } else { @@ -5654,9 +5621,7 @@ } } } - else -#ifdef HAVE_SOCKETS - if (fd < MAXDESC && fd_info[fd].flags & FILE_SOCKET) + else if (fd < MAXDESC && fd_info[fd].flags & FILE_SOCKET) { unsigned long nblock = 0; if (winsock_lib == NULL) abort (); @@ -5684,7 +5649,6 @@ } } else -#endif { /* Some networked filesystems don't like too large writes, so break them into smaller chunks. See the Comments section of @@ -5776,10 +5740,8 @@ void term_ntproc (void) { -#ifdef HAVE_SOCKETS /* shutdown the socket interface if necessary */ term_winsock (); -#endif term_w32select (); } @@ -5787,7 +5749,6 @@ void init_ntproc (void) { -#ifdef HAVE_SOCKETS /* Initialise the socket interface now if available and requested by the user by defining PRELOAD_WINSOCK; otherwise loading will be delayed until open-network-stream is called (w32-has-winsock can @@ -5801,7 +5762,6 @@ if (getenv ("PRELOAD_WINSOCK") != NULL) init_winsock (TRUE); -#endif /* Initial preparation for subprocess support: replace our standard handles with non-inheritable versions. */
--- a/src/w32proc.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/w32proc.c Wed Sep 22 15:46:51 2010 +0900 @@ -1694,8 +1694,6 @@ process_dir = dir; } -#ifdef HAVE_SOCKETS - /* To avoid problems with winsock implementations that work over dial-up connections causing or requiring a connection to exist while Emacs is running, Emacs no longer automatically loads winsock on startup if it @@ -1759,8 +1757,6 @@ return term_winsock () ? Qt : Qnil; } -#endif /* HAVE_SOCKETS */ - /* Some miscellaneous functions that are Windows specific, but not GUI specific (ie. are applicable in terminal or batch mode as well). */ @@ -2268,10 +2264,9 @@ DEFSYM (Qhigh, "high"); DEFSYM (Qlow, "low"); -#ifdef HAVE_SOCKETS defsubr (&Sw32_has_winsock); defsubr (&Sw32_unload_winsock); -#endif + defsubr (&Sw32_short_file_name); defsubr (&Sw32_long_file_name); defsubr (&Sw32_set_process_priority);
--- a/src/xdisp.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/xdisp.c Wed Sep 22 15:46:51 2010 +0900 @@ -3177,7 +3177,7 @@ { register INTERVAL iv, next_iv; Lisp_Object object, limit, position; - EMACS_INT charpos, bytepos, stoppos; + EMACS_INT charpos, bytepos; /* If nowhere else, stop at the end. */ it->stop_charpos = it->end_charpos; @@ -3267,12 +3267,15 @@ } } - if (it->bidi_p && it->bidi_it.scan_dir < 0) - stoppos = -1; - else - stoppos = it->stop_charpos; - composition_compute_stop_pos (&it->cmp_it, charpos, bytepos, - stoppos, it->string); + if (it->cmp_it.id < 0) + { + EMACS_INT stoppos = it->end_charpos; + + if (it->bidi_p && it->bidi_it.scan_dir < 0) + stoppos = -1; + composition_compute_stop_pos (&it->cmp_it, charpos, bytepos, + stoppos, it->string); + } xassert (STRINGP (it->string) || (it->stop_charpos >= BEGV @@ -3821,7 +3824,8 @@ not have a chance to do it, if we are going to skip any text at the beginning, which resets the FIRST_ELT flag. */ - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, + &it->bidi_it, 0); } do { @@ -5143,7 +5147,7 @@ of a new paragraph, next_element_from_buffer may not have a chance to do that. */ if (it->bidi_it.first_elt && it->bidi_it.charpos < ZV) - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, 0); /* prev_stop can be zero, so check against BEGV as well. */ while (it->bidi_it.charpos >= BEGV && it->prev_stop <= it->bidi_it.charpos @@ -6125,7 +6129,7 @@ it->cmp_it.id = -1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), IT_BYTEPOS (*it), - it->stop_charpos, Qnil); + it->end_charpos, Qnil); } } else if (! it->cmp_it.reversed_p) @@ -6148,7 +6152,7 @@ { /* No more grapheme clusters in this composition. Find the next stop position. */ - EMACS_INT stop = it->stop_charpos; + EMACS_INT stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) /* Now we are scanning backward and don't know where to stop. */ @@ -6176,7 +6180,7 @@ { /* No more grapheme clusters in this composition. Find the next stop position. */ - EMACS_INT stop = it->stop_charpos; + EMACS_INT stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) /* Now we are scanning backward and don't know where to stop. */ @@ -6201,7 +6205,7 @@ /* If this is a new paragraph, determine its base direction (a.k.a. its base embedding level). */ if (it->bidi_it.new_paragraph) - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, 0); bidi_move_to_visually_next (&it->bidi_it); IT_BYTEPOS (*it) = it->bidi_it.bytepos; IT_CHARPOS (*it) = it->bidi_it.charpos; @@ -6209,7 +6213,7 @@ { /* As the scan direction was changed, we must re-compute the stop position for composition. */ - EMACS_INT stop = it->stop_charpos; + EMACS_INT stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) stop = -1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), @@ -6287,7 +6291,7 @@ composition_compute_stop_pos (&it->cmp_it, IT_STRING_CHARPOS (*it), IT_STRING_BYTEPOS (*it), - it->stop_charpos, it->string); + it->end_charpos, it->string); } } else @@ -6673,7 +6677,7 @@ { /* If we are at the beginning of a line, we can produce the next element right away. */ - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, 0); bidi_move_to_visually_next (&it->bidi_it); } else @@ -6687,7 +6691,7 @@ IT_BYTEPOS (*it) = CHAR_TO_BYTE (IT_CHARPOS (*it)); it->bidi_it.charpos = IT_CHARPOS (*it); it->bidi_it.bytepos = IT_BYTEPOS (*it); - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, 0); do { /* Now return to buffer position where we were asked to @@ -6704,7 +6708,7 @@ IT_BYTEPOS (*it) = it->bidi_it.bytepos; SET_TEXT_POS (it->position, IT_CHARPOS (*it), IT_BYTEPOS (*it)); { - EMACS_INT stop = it->stop_charpos; + EMACS_INT stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) stop = -1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), @@ -6910,7 +6914,7 @@ if (it->bidi_p) { if (it->bidi_it.new_paragraph) - bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it); + bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, 0); /* Resync the bidi iterator with IT's new position. FIXME: this doesn't support bidirectional text. */ while (it->bidi_it.charpos < IT_CHARPOS (*it)) @@ -17992,8 +17996,9 @@ itb.bytepos = bytepos; itb.first_elt = 1; itb.separator_limit = -1; - - bidi_paragraph_init (NEUTRAL_DIR, &itb); + itb.paragraph_dir = NEUTRAL_DIR; + + bidi_paragraph_init (NEUTRAL_DIR, &itb, 1); if (buf != current_buffer) set_buffer_temp (old); switch (itb.paragraph_dir)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xml.c Wed Sep 22 15:46:51 2010 +0900 @@ -0,0 +1,141 @@ +/* Interface to libxml2. + Copyright (C) 2010 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 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> + +#ifdef HAVE_LIBXML2 + +#include <setjmp.h> +#include <libxml/tree.h> +#include <libxml/parser.h> +#include <libxml/HTMLparser.h> + +#include "lisp.h" +#include "buffer.h" + +Lisp_Object make_dom (xmlNode *node) +{ + if (node->type == XML_ELEMENT_NODE) { + Lisp_Object result = Fcons (intern (node->name), Qnil); + xmlNode *child; + xmlAttr *property; + + /* First add the attributes. */ + property = node->properties; + while (property != NULL) { + if (property->children && + property->children->content) { + char *pname = xmalloc (strlen (property->name) + 2); + *pname = ':'; + strcpy(pname + 1, property->name); + result = Fcons (Fcons (intern (pname), + build_string(property->children->content)), + result); + xfree (pname); + } + property = property->next; + } + /* Then add the children of the node. */ + child = node->children; + while (child != NULL) { + result = Fcons (make_dom (child), result); + child = child->next; + } + return Fnreverse (result); + } else if (node->type == XML_TEXT_NODE) { + Lisp_Object content = Qnil; + + if (node->content) + content = build_string (node->content); + + return Fcons (intern (node->name), content); + } else + return Qnil; +} + +static Lisp_Object +parse_string (Lisp_Object string, Lisp_Object base_url, int htmlp) +{ + xmlDoc *doc; + xmlNode *node; + Lisp_Object result = Qnil; + int ibeg, iend; + char *burl = ""; + + LIBXML_TEST_VERSION; + + CHECK_STRING (string); + + if (! NILP (base_url)) { + CHECK_STRING (base_url); + burl = SDATA (base_url); + } + + if (htmlp) + doc = htmlReadMemory (SDATA (string), SBYTES (string), burl, "utf-8", + HTML_PARSE_RECOVER|HTML_PARSE_NONET| + HTML_PARSE_NOWARNING|HTML_PARSE_NOERROR); + else + doc = xmlReadMemory (SDATA (string), SBYTES (string), burl, "utf-8", + XML_PARSE_NONET|XML_PARSE_NOWARNING| + XML_PARSE_NOERROR); + + if (doc != NULL) { + node = xmlDocGetRootElement (doc); + if (node != NULL) + result = make_dom (node); + + xmlFreeDoc (doc); + xmlCleanupParser (); + } + + return result; +} + +DEFUN ("html-parse-string", Fhtml_parse_string, Shtml_parse_string, + 1, 2, 0, + doc: /* Parse STRING as an HTML document and return the parse tree. +If BASE-URL is non-nil, it will be used to expand relative URLs in +the HTML document. */) + (Lisp_Object string, Lisp_Object base_url) +{ + return parse_string (string, base_url, 1); +} + +DEFUN ("xml-parse-string", Fxml_parse_string, Sxml_parse_string, + 1, 2, 0, + doc: /* Parse STRING as an XML document and return the parse tree. +If BASE-URL is non-nil, it will be used to expand relative URLs in +the XML document. */) + (Lisp_Object string, Lisp_Object base_url) +{ + return parse_string (string, base_url, 0); +} + + +/*********************************************************************** + Initialization + ***********************************************************************/ +void +syms_of_xml (void) +{ + defsubr (&Shtml_parse_string); + defsubr (&Sxml_parse_string); +} + +#endif /* HAVE_LIBXML2 */
--- a/src/xterm.c Wed Sep 08 12:55:57 2010 +0900 +++ b/src/xterm.c Wed Sep 22 15:46:51 2010 +0900 @@ -4004,7 +4004,7 @@ XEvent *event, String *params, Cardinal *num_params) { int scroll_bar_p; - char *end_action; + const char *end_action; #ifdef USE_MOTIF scroll_bar_p = XmIsScrollBar (widget); @@ -8285,19 +8285,89 @@ "_NET_WM_STATE_STICKY", NULL); } +/* Return the current _NET_WM_STATE. + SIZE_STATE is set to one of the FULLSCREEN_* values. + STICKY is set to 1 if the sticky state is set, 0 if not. */ + +static void +get_current_vm_state (struct frame *f, + Window window, + int *size_state, + int *sticky) +{ + Atom actual_type; + unsigned long actual_size, bytes_remaining; + int i, rc, actual_format; + struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + long max_len = 65536; + Display *dpy = FRAME_X_DISPLAY (f); + unsigned char *tmp_data = NULL; + Atom target_type = XA_ATOM; + + *sticky = 0; + *size_state = FULLSCREEN_NONE; + + BLOCK_INPUT; + x_catch_errors (dpy); + rc = XGetWindowProperty (dpy, window, dpyinfo->Xatom_net_wm_state, + 0, max_len, False, target_type, + &actual_type, &actual_format, &actual_size, + &bytes_remaining, &tmp_data); + + if (rc != Success || actual_type != target_type || x_had_errors_p (dpy)) + { + if (tmp_data) XFree (tmp_data); + x_uncatch_errors (); + UNBLOCK_INPUT; + return; + } + + x_uncatch_errors (); + + for (i = 0; i < actual_size; ++i) + { + Atom a = ((Atom*)tmp_data)[i]; + if (a == dpyinfo->Xatom_net_wm_state_maximized_horz) + { + if (*size_state == FULLSCREEN_HEIGHT) + *size_state = FULLSCREEN_MAXIMIZED; + else + *size_state = FULLSCREEN_WIDTH; + } + else if (a == dpyinfo->Xatom_net_wm_state_maximized_vert) + { + if (*size_state == FULLSCREEN_WIDTH) + *size_state = FULLSCREEN_MAXIMIZED; + else + *size_state = FULLSCREEN_HEIGHT; + } + else if (a == dpyinfo->Xatom_net_wm_state_fullscreen_atom) + *size_state = FULLSCREEN_BOTH; + else if (a == dpyinfo->Xatom_net_wm_state_sticky) + *sticky = 1; + } + + if (tmp_data) XFree (tmp_data); + UNBLOCK_INPUT; +} + /* Do fullscreen as specified in extended window manager hints */ static int do_ewmh_fullscreen (struct frame *f) { int have_net_atom = wm_supports (f, "_NET_WM_STATE"); + Lisp_Object lval = get_frame_param (f, Qfullscreen); + int cur, dummy; + + get_current_vm_state (f, FRAME_OUTER_WINDOW (f), &cur, &dummy); /* Some window managers don't say they support _NET_WM_STATE, but they do say they support _NET_WM_STATE_FULLSCREEN. Try that also. */ if (!have_net_atom) have_net_atom = wm_supports (f, "_NET_WM_STATE_FULLSCREEN"); - if (have_net_atom) + if (have_net_atom && cur != f->want_fullscreen) { Lisp_Object frame; const char *fs = "_NET_WM_STATE_FULLSCREEN"; @@ -8306,26 +8376,41 @@ XSETFRAME (frame, f); - set_wm_state (frame, 0, fs, NULL); - set_wm_state (frame, 0, fh, NULL); - set_wm_state (frame, 0, fw, NULL); - - /* If there are _NET_ atoms we assume we have extended window manager - hints. */ + /* Keep number of calls to set_wm_state as low as possible. + Some window managers, or possible Gtk+, hangs when too many + are sent at once. */ switch (f->want_fullscreen) { case FULLSCREEN_BOTH: + if (cur == FULLSCREEN_WIDTH || cur == FULLSCREEN_MAXIMIZED + || cur == FULLSCREEN_HEIGHT) + set_wm_state (frame, 0, fw, fh); set_wm_state (frame, 1, fs, NULL); break; case FULLSCREEN_WIDTH: - set_wm_state (frame, 1, fw, NULL); + if (cur == FULLSCREEN_BOTH || cur == FULLSCREEN_HEIGHT + || cur == FULLSCREEN_MAXIMIZED) + set_wm_state (frame, 0, fs, fh); + if (cur != FULLSCREEN_MAXIMIZED) + set_wm_state (frame, 1, fw, NULL); break; case FULLSCREEN_HEIGHT: - set_wm_state (frame, 1, fh, NULL); + if (cur == FULLSCREEN_BOTH || cur == FULLSCREEN_WIDTH + || cur == FULLSCREEN_MAXIMIZED) + set_wm_state (frame, 0, fs, fw); + if (cur != FULLSCREEN_MAXIMIZED) + set_wm_state (frame, 1, fh, NULL); break; case FULLSCREEN_MAXIMIZED: + if (cur == FULLSCREEN_BOTH) + set_wm_state (frame, 0, fs, NULL); set_wm_state (frame, 1, fw, fh); break; + case FULLSCREEN_NONE: + if (cur == FULLSCREEN_BOTH) + set_wm_state (frame, 0, fs, NULL); + else + set_wm_state (frame, 0, fw, fh); } f->want_fullscreen = FULLSCREEN_NONE; @@ -8351,57 +8436,11 @@ static void x_handle_net_wm_state (struct frame *f, XPropertyEvent *event) { - Atom actual_type; - unsigned long actual_size, bytes_remaining; - int i, rc, actual_format, value = FULLSCREEN_NONE; - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - long max_len = 65536; - Display *dpy = FRAME_X_DISPLAY (f); - unsigned char *tmp_data = NULL; - Atom target_type = XA_ATOM; + int value = FULLSCREEN_NONE; Lisp_Object lval; int sticky = 0; - BLOCK_INPUT; - x_catch_errors (dpy); - rc = XGetWindowProperty (dpy, event->window, - event->atom, 0, max_len, False, target_type, - &actual_type, &actual_format, &actual_size, - &bytes_remaining, &tmp_data); - - if (rc != Success || actual_type != target_type || x_had_errors_p (dpy)) - { - if (tmp_data) XFree (tmp_data); - x_uncatch_errors (); - UNBLOCK_INPUT; - return; - } - - x_uncatch_errors (); - - for (i = 0; i < actual_size; ++i) - { - Atom a = ((Atom*)tmp_data)[i]; - if (a == dpyinfo->Xatom_net_wm_state_maximized_horz) - { - if (value == FULLSCREEN_HEIGHT) - value = FULLSCREEN_MAXIMIZED; - else - value = FULLSCREEN_WIDTH; - } - else if (a == dpyinfo->Xatom_net_wm_state_maximized_vert) - { - if (value == FULLSCREEN_WIDTH) - value = FULLSCREEN_MAXIMIZED; - else - value = FULLSCREEN_HEIGHT; - } - else if (a == dpyinfo->Xatom_net_wm_state_fullscreen_atom) - value = FULLSCREEN_BOTH; - else if (a == dpyinfo->Xatom_net_wm_state_sticky) - sticky = 1; - } - + get_current_vm_state (f, event->window, &value, &sticky); lval = Qnil; switch (value) { @@ -8421,9 +8460,6 @@ store_frame_param (f, Qfullscreen, lval); store_frame_param (f, Qsticky, sticky ? Qt : Qnil); - - if (tmp_data) XFree (tmp_data); - UNBLOCK_INPUT; } /* Check if we need to resize the frame due to a fullscreen request.
--- a/test/ChangeLog Wed Sep 08 12:55:57 2010 +0900 +++ b/test/ChangeLog Wed Sep 22 15:46:51 2010 +0900 @@ -1,3 +1,15 @@ +2010-09-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/prolog.prolog: Use normal spacing around !. + +2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: Remove one more `fixindent'. Use `end'. + +2010-09-10 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: Remove some `fixindent' not needed any more. + 2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> * indent/octave.m: New file. @@ -14,7 +26,8 @@ (icalendar-testsuite--do-test-export): Code formatting. (icalendar-testsuite--test-parse-vtimezone): Doc fix. (icalendar-testsuite--do-test-import) - (icalendar-testsuite--do-test-cycle): Use icalendar-testsuite--compare-strings + (icalendar-testsuite--do-test-cycle): + Use icalendar-testsuite--compare-strings (icalendar-testsuite--run-import-tests): Comment added. (icalendar-testsuite--run-import-tests) (icalendar-testsuite--run-real-world-tests): Fix expected results.
--- a/test/indent/octave.m Wed Sep 08 12:55:57 2010 +0900 +++ b/test/indent/octave.m Wed Sep 22 15:46:51 2010 +0900 @@ -6,7 +6,7 @@ if nargin ~= 1 print_usage() - endif + end data = dlmread(fn, 3, 0); @@ -1412,10 +1412,10 @@ for i = 1:length (lst) nam = fullfile (packdir, "inst", lst(i).name); fwrite (instfid, extract_pkg (nam, ['^[#%][#%]* *' nm ': *(.*)$'])); - endfor # fixindent + endfor ## Search all C++ source files for PKG commands. - lst = dir (fullfile (packdir, "src", "*.cc")); # fixindent + lst = dir (fullfile (packdir, "src", "*.cc")); for i = 1:length (lst) nam = fullfile (packdir, "src", lst(i).name); fwrite (archfid, extract_pkg (nam, ['^//* *' nm ': *(.*)$'])); @@ -1451,10 +1451,10 @@ unlink (archpkg); endif endif - endif # fixindent -endfunction # fixindent + endif +endfunction -function copy_files (desc, packdir, global_install) # fixindent +function copy_files (desc, packdir, global_install) ## Create the installation directory. if (! exist (desc.dir, "dir")) [status, output] = mkdir (desc.dir);
--- a/test/indent/prolog.prolog Wed Sep 08 12:55:57 2010 +0900 +++ b/test/indent/prolog.prolog Wed Sep 22 15:46:51 2010 +0900 @@ -150,7 +150,7 @@ %% instantiate(+X, +T, -E) %% Utilise la variable X de type T. Le résultat E est X auquel on ajoute %% tous les arguments implicites (de valeur inconnue). -instantiate(X, T, X) :- var(T), ! . +instantiate(X, T, X) :- var(T), !. instantiate(X, forall(_, _, T), app(E, _)) :- !, instantiate(X, T, E). instantiate(X, _, X).